home *** CD-ROM | disk | FTP | other *** search
/ Supercompiler 1997 / SUPERCOMPILER97.iso / BC++ Builder / DATA.Z / FORMS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-02-10  |  140.7 KB  |  4,858 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1995-1997 Borland International   }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit Forms;            // $Revision:   1.12  $
  11.  
  12. {$P+,S-,W-,R-}
  13. {$C PRELOAD}
  14.  
  15. interface
  16.  
  17. uses Messages, Windows, SysUtils, Classes, Graphics, Menus, Controls;
  18.  
  19. type
  20.  
  21. { Forward declarations }
  22.  
  23.   TScrollingWinControl = class;
  24.   TForm = class;
  25.  
  26. { TControlScrollBar }
  27.  
  28.   TScrollBarKind = (sbHorizontal, sbVertical);
  29.   TScrollBarInc = 1..32767;
  30.  
  31.   TControlScrollBar = class(TPersistent)
  32.   private
  33.     FControl: TScrollingWinControl;
  34.     FIncrement: TScrollBarInc;
  35.     FPosition: Integer;
  36.     FRange: Integer;
  37.     FCalcRange: Integer;
  38.     FKind: TScrollBarKind;
  39.     FMargin: Word;
  40.     FVisible: Boolean;
  41.     FTracking: Boolean;
  42.     FScaled: Boolean;
  43.     constructor Create(AControl: TScrollingWinControl; AKind: TScrollBarKind);
  44.     procedure CalcAutoRange;
  45.     function ControlSize(ControlSB, AssumeSB: Boolean): Integer;
  46.     procedure DoSetRange(Value: Integer);
  47.     function GetScrollPos: Integer;
  48.     function NeedsScrollBarVisible: Boolean;
  49.     procedure ScrollMessage(var Msg: TWMScroll);
  50.     procedure SetPosition(Value: Integer);
  51.     procedure SetRange(Value: Integer);
  52.     procedure SetVisible(Value: Boolean);
  53.     function IsRangeStored: Boolean;
  54.     procedure Update(ControlSB, AssumeSB: Boolean);
  55.   public
  56.     procedure Assign(Source: TPersistent); override;
  57.     property Kind: TScrollBarKind read FKind;
  58.     property ScrollPos: Integer read GetScrollPos;
  59.   published
  60.     property Margin: Word read FMargin write FMargin default 0;
  61.     property Increment: TScrollBarInc read FIncrement write FIncrement default 8;
  62.     property Range: Integer read FRange write SetRange stored IsRangeStored default 0;
  63.     property Position: Integer read FPosition write SetPosition default 0;
  64.     property Tracking: Boolean read FTracking write FTracking default False;
  65.     property Visible: Boolean read FVisible write SetVisible default True;
  66.   end;
  67.  
  68. { TScrollingWinControl }
  69.  
  70.   TScrollingWinControl = class(TWinControl)
  71.   private
  72.     FHorzScrollBar: TControlScrollBar;
  73.     FVertScrollBar: TControlScrollBar;
  74.     FAutoScroll: Boolean;
  75.     FSizing: Boolean;
  76.     FUpdatingScrollBars: Boolean;
  77.     FReserved: Byte;
  78.     procedure CalcAutoRange;
  79.     procedure ScaleScrollBars(M, D: Integer);
  80.     procedure SetAutoScroll(Value: Boolean);
  81.     procedure SetHorzScrollBar(Value: TControlScrollBar);
  82.     procedure SetVertScrollBar(Value: TControlScrollBar);
  83.     procedure UpdateScrollBars;
  84.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  85.     procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
  86.     procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
  87.   protected
  88.     procedure AutoScrollInView(AControl: TControl);
  89.     procedure ChangeScale(M, D: Integer); override;
  90.     procedure CreateWnd; override;
  91.     procedure AlignControls(AControl: TControl; var ARect: TRect); override;
  92.     property AutoScroll: Boolean read FAutoScroll write SetAutoScroll default True;
  93.   public
  94.     constructor Create(AOwner: TComponent); override;
  95.     destructor Destroy; override;
  96.     procedure ScrollInView(AControl: TControl);
  97.   published
  98.     property HorzScrollBar: TControlScrollBar read FHorzScrollBar write SetHorzScrollBar;
  99.     property VertScrollBar: TControlScrollBar read FVertScrollBar write SetVertScrollBar;
  100.   end;
  101.  
  102. { TScrollBox }
  103.  
  104.   TFormBorderStyle = (bsNone, bsSingle, bsSizeable, bsDialog, bsToolWindow,
  105.     bsSizeToolWin);
  106.   TBorderStyle = bsNone..bsSingle;
  107.  
  108.   TScrollBox = class(TScrollingWinControl)
  109.   private
  110.     FBorderStyle: TBorderStyle;
  111.     FReserved: Byte;
  112.     FOnResize: TNotifyEvent;
  113.     procedure SetBorderStyle(Value: TBorderStyle);
  114.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  115.     procedure WMNCHitTest(var Message: TMessage); message WM_NCHITTEST;
  116.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  117.   protected
  118.     procedure CreateParams(var Params: TCreateParams); override;
  119.     procedure Resize; dynamic;
  120.   public
  121.     constructor Create(AOwner: TComponent); override;
  122.   published
  123.     property Align;
  124.     property AutoScroll;
  125.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  126.     property DragCursor;
  127.     property DragMode;
  128.     property Enabled;
  129.     property Color nodefault;
  130.     property Ctl3D;
  131.     property Font;
  132.     property ParentColor;
  133.     property ParentCtl3D;
  134.     property ParentFont;
  135.     property ParentShowHint;
  136.     property PopupMenu;
  137.     property ShowHint;
  138.     property TabOrder;
  139.     property TabStop;
  140.     property Visible;
  141.     property OnClick;
  142.     property OnDblClick;
  143.     property OnDragDrop;
  144.     property OnDragOver;
  145.     property OnEndDrag;
  146.     property OnEnter;
  147.     property OnExit;
  148.     property OnMouseDown;
  149.     property OnMouseMove;
  150.     property OnMouseUp;
  151.     property OnResize: TNotifyEvent read FOnResize write FOnResize;
  152.   end;
  153.  
  154. { TDesigner }
  155.  
  156.   TDesigner = class(TObject)
  157.   private
  158.     FForm: TForm;
  159.     function GetIsControl: Boolean;
  160.     procedure SetIsControl(Value: Boolean);
  161.   public
  162.     function IsDesignMsg(Sender: TControl; var Message: TMessage): Boolean;
  163.       virtual; abstract;
  164.     procedure Modified; virtual; abstract;
  165.     procedure Notification(AComponent: TComponent;
  166.       Operation: TOperation); virtual; abstract;
  167.     procedure PaintGrid; virtual; abstract;
  168.     procedure ValidateRename(AComponent: TComponent;
  169.       const CurName, NewName: string); virtual; abstract;
  170.     property IsControl: Boolean read GetIsControl write SetIsControl;
  171.     property Form: TForm read FForm write FForm;
  172.   end;
  173.  
  174. { TOleFormObject }
  175.  
  176.   TOleFormObject = class(TObject)
  177.   protected
  178.     procedure OnDestroy; virtual; abstract;
  179.     procedure OnResize; virtual; abstract;
  180.   end;
  181.  
  182. { TForm }
  183.  
  184.   TWindowState = (wsNormal, wsMinimized, wsMaximized);
  185.   TFormStyle = (fsNormal, fsMDIChild, fsMDIForm, fsStayOnTop);
  186.   TBorderIcon = (biSystemMenu, biMinimize, biMaximize, biHelp);
  187.   TBorderIcons = set of TBorderIcon;
  188.   TPosition = (poDesigned, poDefault, poDefaultPosOnly, poDefaultSizeOnly,
  189.     poScreenCenter);
  190.   TPrintScale = (poNone, poProportional, poPrintToFit);
  191.   TShowAction = (saIgnore, saRestore, saMinimize, saMaximize);
  192.   TTileMode = (tbHorizontal, tbVertical);
  193.   TModalResult = Low(Integer)..High(Integer);
  194.   TCloseAction = (caNone, caHide, caFree, caMinimize);
  195.   TCloseEvent = procedure(Sender: TObject; var Action: TCloseAction) of object;
  196.   TCloseQueryEvent = procedure(Sender: TObject;
  197.     var CanClose: Boolean) of object;
  198.   TFormState = set of (fsCreating, fsVisible, fsShowing, fsModal,
  199.     fsCreatedMDIChild);
  200.  
  201.   TForm = class(TScrollingWinControl)
  202.   private
  203.     FActiveControl: TWinControl;
  204.     FFocusedControl: TWinControl;
  205.     FBorderIcons: TBorderIcons;
  206.     FBorderStyle: TFormBorderStyle;
  207.     FWindowState: TWindowState;
  208.     FShowAction: TShowAction;
  209.     FKeyPreview: Boolean;
  210.     FActive: Boolean;
  211.     FIgnoreFontProperty: Boolean;
  212.     FFormStyle: TFormStyle;
  213.     FPosition: TPosition;
  214.     FTileMode: TTileMode;
  215.     FFormState: TFormState;
  216.     FDropTarget: Boolean;
  217.     FPrintScale: TPrintScale;
  218.     FCanvas: TControlCanvas;
  219.     FIcon: TIcon;
  220.     FMenu: TMainMenu;
  221.     FModalResult: TModalResult;
  222.     FDesigner: TDesigner;
  223.     FClientHandle: HWND;
  224.     FWindowMenu: TMenuItem;
  225.     FPixelsPerInch: Integer;
  226.     FObjectMenuItem: TMenuItem;
  227.     FOleFormObject: TOleFormObject;
  228.     FClientWidth: Integer;
  229.     FClientHeight: Integer;
  230.     FTextHeight: Integer;
  231.     FDefClientProc: TFarProc;
  232.     FClientInstance: TFarProc;
  233.     FActiveOleControl: TWinControl;
  234.     FOnActivate: TNotifyEvent;
  235.     FOnClose: TCloseEvent;
  236.     FOnCloseQuery: TCloseQueryEvent;
  237.     FOnDeactivate: TNotifyEvent;
  238.     FOnHide: TNotifyEvent;
  239.     FOnPaint: TNotifyEvent;
  240.     FOnResize: TNotifyEvent;
  241.     FOnShow: TNotifyEvent;
  242.     FOnCreate: TNotifyEvent;
  243.     FOnDestroy: TNotifyEvent;
  244.     procedure AlignControls(AControl: TControl; var Rect: TRect); override;
  245.     procedure RefreshMDIMenu;
  246.     procedure ClientWndProc(var Message: TMessage);
  247.     procedure CloseModal;
  248.     function GetActiveMDIChild: TForm;
  249.     function GetCanvas: TCanvas;
  250.     function GetIconHandle: HICON;
  251.     function GetMDIChildCount: Integer;
  252.     function GetMDIChildren(I: Integer): TForm;
  253.     function GetPixelsPerInch: Integer;
  254.     function GetScaled: Boolean;
  255.     function GetTextHeight: Integer;
  256.     procedure IconChanged(Sender: TObject);
  257.     function IsAutoScrollStored: Boolean;
  258.     function IsClientSizeStored: Boolean;
  259.     function IsColorStored: Boolean;
  260.     function IsForm: Boolean;
  261.     function IsFormSizeStored: Boolean;
  262.     function IsIconStored: Boolean;
  263.     procedure MergeMenu(MergeState: Boolean);
  264.     procedure ReadTextHeight(Reader: TReader);
  265.     procedure SetActive(Value: Boolean);
  266.     procedure SetActiveControl(Control: TWinControl);
  267.     procedure SetBorderIcons(Value: TBorderIcons);
  268.     procedure SetBorderStyle(Value: TFormBorderStyle);
  269.     procedure SetClientHeight(Value: Integer);
  270.     procedure SetClientWidth(Value: Integer);
  271.     procedure SetDesigner(ADesigner: TDesigner);
  272.     procedure SetFormStyle(Value: TFormStyle);
  273.     procedure SetIcon(Value: TIcon);
  274.     procedure SetMenu(Value: TMainMenu);
  275.     procedure SetPixelsPerInch(Value: Integer);
  276.     procedure SetPosition(Value: TPosition);
  277.     procedure SetScaled(Value: Boolean);
  278.     procedure SetVisible(Value: Boolean);
  279.     procedure SetWindowFocus;
  280.     procedure SetWindowMenu(Value: TMenuItem);
  281.     procedure SetObjectMenuItem(Value: TMenuItem);
  282.     procedure SetWindowState(Value: TWindowState);
  283.     procedure WritePixelsPerInch(Writer: TWriter);
  284.     procedure WriteTextHeight(Writer: TWriter);
  285.     function NormalColor: TColor;
  286.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  287.     procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  288.     procedure WMIconEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ICONERASEBKGND;
  289.     procedure WMQueryDragIcon(var Message: TWMQueryDragIcon); message WM_QUERYDRAGICON;
  290.     procedure WMNCCreate(var Message: TWMNCCreate); message WM_NCCREATE;
  291.     procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
  292.     procedure WMCommand(var Message: TWMCommand); message WM_COMMAND;
  293.     procedure WMInitMenuPopup(var Message: TWMInitMenuPopup); message WM_INITMENUPOPUP;
  294.     procedure WMMenuSelect(var Message: TWMMenuSelect); message WM_MENUSELECT;
  295.     procedure WMActivate(var Message: TWMActivate); message WM_ACTIVATE;
  296.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  297.     procedure WMClose(var Message: TWMClose); message WM_CLOSE;
  298.     procedure WMQueryEndSession(var Message: TWMQueryEndSession); message WM_QUERYENDSESSION;
  299.     procedure WMSysCommand(var Message: TWMSysCommand); message WM_SYSCOMMAND;
  300.     procedure WMShowWindow(var Message: TWMShowWindow); message WM_SHOWWINDOW;
  301.     procedure WMMDIActivate(var Message: TWMMDIActivate); message WM_MDIACTIVATE;
  302.     procedure WMNextDlgCtl(var Message: TWMNextDlgCtl); message WM_NEXTDLGCTL;
  303.     procedure WMEnterMenuLoop(var Message: TMessage); message WM_ENTERMENULOOP;
  304.     procedure WMHelp(var Message: TWMHelp); message WM_HELP;
  305.     procedure CMActivate(var Message: TCMActivate); message CM_ACTIVATE;
  306.     procedure CMAppSysCommand(var Message: TMessage); message CM_APPSYSCOMMAND;
  307.     procedure CMDeactivate(var Message: TCMDeactivate); message CM_DEACTIVATE;
  308.     procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
  309.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  310.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  311.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  312.     procedure CMMenuChanged(var Message: TMessage); message CM_MENUCHANGED;
  313.     procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;
  314.     procedure CMIconChanged(var Message: TMessage); message CM_ICONCHANGED;
  315.     procedure CMRelease(var Message: TMessage); message CM_RELEASE;
  316.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  317.     procedure CMUIActivate(var Message); message CM_UIACTIVATE;
  318.   protected
  319.     procedure Activate; dynamic;
  320.     procedure ActiveChanged; dynamic;
  321.     procedure ChangeScale(M, D: Integer); override;
  322.     procedure CreateParams(var Params: TCreateParams); override;
  323.     procedure CreateWindowHandle(const Params: TCreateParams); override;
  324.     procedure CreateWnd; override;
  325.     procedure Deactivate; dynamic;
  326.     procedure DefaultHandler(var Message); override;
  327.     procedure DefineProperties(Filer: TFiler); override;
  328.     procedure DestroyWindowHandle; override;
  329.     procedure DoHide; dynamic;
  330.     procedure DoShow; dynamic;
  331.     function GetClientRect: TRect; override;
  332.     procedure GetChildren(Proc: TGetChildProc); override;
  333.     procedure Notification(AComponent: TComponent;
  334.       Operation: TOperation); override;
  335.     procedure Paint; dynamic;
  336.     procedure PaintWindow(DC: HDC); override;
  337.     function PaletteChanged(Foreground: Boolean): Boolean; override;
  338.     procedure SetChildOrder(Child: TComponent; Order: Integer); override;
  339.     procedure ReadState(Reader: TReader); override;
  340.     procedure Resize; dynamic;
  341.     procedure SetParent(AParent: TWinControl); override;
  342.     procedure ValidateRename(AComponent: TComponent;
  343.       const CurName, NewName: string); override;
  344.     procedure VisibleChanging; override;
  345.     procedure WndProc(var Message: TMessage); override;
  346.     procedure AfterConstruction; override;
  347.     procedure BeforeDestruction; override;
  348.   public
  349.     constructor Create(AOwner: TComponent); override;
  350.     constructor CreateNew(AOwner: TComponent; Dummy: Integer);
  351.     destructor Destroy; override;
  352.     procedure ArrangeIcons;
  353.     procedure Cascade;
  354.     procedure Close;
  355.     function CloseQuery: Boolean;
  356.     procedure DefocusControl(Control: TWinControl; Removing: Boolean);
  357.     procedure FocusControl(Control: TWinControl);
  358.     function GetFormImage: TBitmap;
  359.     procedure Hide;
  360.     procedure Next;
  361.     procedure Previous;
  362.     procedure Print;
  363.     procedure Release;
  364.     procedure SendCancelMode(Sender: TControl);
  365.     procedure SetFocus; override;
  366.     function SetFocusedControl(Control: TWinControl): Boolean;
  367.     procedure Show;
  368.     function ShowModal: Integer;
  369.     procedure Tile;
  370.     property Active: Boolean read FActive;
  371.     property ActiveMDIChild: TForm read GetActiveMDIChild;
  372.     property ActiveOleControl: TWinControl read FActiveOleControl write FActiveOleControl;
  373.     property Canvas: TCanvas read GetCanvas;
  374.     property ClientHandle: HWND read FClientHandle;
  375.     property Designer: TDesigner read FDesigner write SetDesigner;
  376.     property DropTarget: Boolean read FDropTarget write FDropTarget;
  377.     property IgnoreFontProperty: Boolean read FIgnoreFontProperty write FIgnoreFontProperty;
  378.     property ModalResult: TModalResult read FModalResult write FModalResult;
  379.     property MDIChildCount: Integer read GetMDIChildCount;
  380.     property MDIChildren[I: Integer]: TForm read GetMDIChildren;
  381.     property OleFormObject: TOleFormObject read FOleFormObject write FOleFormObject;
  382.     property TileMode: TTileMode read FTileMode write FTileMode default tbHorizontal;
  383.   published
  384.     property ActiveControl: TWinControl read FActiveControl write SetActiveControl
  385.       stored IsForm;
  386.     property BorderIcons: TBorderIcons read FBorderIcons write SetBorderIcons stored IsForm
  387.       default [biSystemMenu, biMinimize, biMaximize];
  388.     property BorderStyle: TFormBorderStyle read FBorderStyle write SetBorderStyle
  389.       stored IsForm default bsSizeable;
  390.     property AutoScroll stored IsAutoScrollStored;
  391.     property Caption stored IsForm;
  392.     property ClientHeight write SetClientHeight stored IsClientSizeStored;
  393.     property ClientWidth write SetClientWidth stored IsClientSizeStored;
  394.     property Ctl3D default True;
  395.     property Color stored IsColorStored;
  396.     property Enabled;
  397.     property Font;
  398.     property FormStyle: TFormStyle read FFormStyle write SetFormStyle
  399.       stored IsForm default fsNormal;
  400.     property Height stored IsFormSizeStored;
  401.     property HorzScrollBar stored IsForm;
  402.     property Icon: TIcon read FIcon write SetIcon stored IsIconStored;
  403.     property KeyPreview: Boolean read FKeyPreview write FKeyPreview
  404.       stored IsForm default False;
  405.     property Menu: TMainMenu read FMenu write SetMenu stored IsForm;
  406.     property ObjectMenuItem: TMenuItem read FObjectMenuItem write SetObjectMenuItem
  407.       stored IsForm;
  408.     property PixelsPerInch: Integer read GetPixelsPerInch write SetPixelsPerInch
  409.       stored False;
  410.     property PopupMenu stored IsForm;
  411.     property Position: TPosition read FPosition write SetPosition stored IsForm
  412.       default poDesigned;
  413.     property PrintScale: TPrintScale read FPrintScale write FPrintScale stored IsForm
  414.       default poProportional;
  415.     property Scaled: Boolean read GetScaled write SetScaled stored IsForm default True;
  416.     property ShowHint;
  417.     property VertScrollBar stored IsForm;
  418.     property Visible write SetVisible default False;
  419.     property Width stored IsFormSizeStored;
  420.     property WindowState: TWindowState read FWindowState write SetWindowState
  421.       stored IsForm default wsNormal;
  422.     property WindowMenu: TMenuItem read FWindowMenu write SetWindowMenu stored IsForm;
  423.     property OnActivate: TNotifyEvent read FOnActivate write FOnActivate stored IsForm;
  424.     property OnClick stored IsForm;
  425.     property OnClose: TCloseEvent read FOnClose write FOnClose stored IsForm;
  426.     property OnCloseQuery: TCloseQueryEvent read FOnCloseQuery write FOnCloseQuery
  427.       stored IsForm;
  428.     property OnCreate: TNotifyEvent read FOnCreate write FOnCreate stored IsForm;
  429.     property OnDblClick stored IsForm;
  430.     property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy stored IsForm;
  431.     property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate stored IsForm;
  432.     property OnDragDrop stored IsForm;
  433.     property OnDragOver stored IsForm;
  434.     property OnHide: TNotifyEvent read FOnHide write FOnHide stored IsForm;
  435.     property OnKeyDown stored IsForm;
  436.     property OnKeyPress stored IsForm;
  437.     property OnKeyUp stored IsForm;
  438.     property OnMouseDown stored IsForm;
  439.     property OnMouseMove stored IsForm;
  440.     property OnMouseUp stored IsForm;
  441.     property OnPaint: TNotifyEvent read FOnPaint write FOnPaint stored IsForm;
  442.     property OnResize: TNotifyEvent read FOnResize write FOnResize stored IsForm;
  443.     property OnShow: TNotifyEvent read FOnShow write FOnShow stored IsForm;
  444.   end;
  445.  
  446.   TFormClass = class of TForm;
  447.  
  448. { TDataModule }
  449.  
  450.   TDataModule = class(TComponent)
  451.   private
  452.     FDesignSize: TPoint;
  453.     FDesignOffset: TPoint;
  454.     FOnCreate: TNotifyEvent;
  455.     FOnDestroy: TNotifyEvent;
  456.     procedure ReadHeight(Reader: TReader);
  457.     procedure ReadHorizontalOffset(Reader: TReader);
  458.     procedure ReadVerticalOffset(Reader: TReader);
  459.     procedure ReadWidth(Reader: TReader);
  460.     procedure WriteWidth(Writer: TWriter);
  461.     procedure WriteHorizontalOffset(Writer: TWriter);
  462.     procedure WriteVerticalOffset(Writer: TWriter);
  463.     procedure WriteHeight(Writer: TWriter);
  464.   protected
  465.     procedure DefineProperties(Filer: TFiler); override;
  466.     procedure GetChildren(Proc: TGetChildProc); override;
  467.     procedure AfterConstruction; override;
  468.     procedure BeforeDestruction; override;
  469.   public
  470.     constructor Create(AOwner: TComponent); override;
  471.     constructor CreateNew(AOwner: TComponent; Dummy: Integer);
  472.     destructor Destroy; override;
  473.     property DesignOffset: TPoint read FDesignOffset write FDesignOffset;
  474.     property DesignSize: TPoint read FDesignSize write FDesignSize;
  475.   published
  476.     property OnCreate: TNotifyEvent read FOnCreate write FOnCreate;
  477.     property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
  478.   end;
  479.  
  480. { TScreen }
  481.  
  482.   PCursorRec = ^TCursorRec;
  483.   TCursorRec = record
  484.     Next: PCursorRec;
  485.     Index: Integer;
  486.     Handle: HCURSOR;
  487.   end;
  488.  
  489.   TScreen = class(TComponent)
  490.   private
  491.     FFonts: TStrings;
  492.     FImes: TStrings;
  493.     FDefaultIme: string;
  494.     FDefaultKbLayout: HKL;
  495.     FRestoreFocusForms: TList;
  496.     FPixelsPerInch: Integer;
  497.     FCursor: TCursor;
  498.     FForms: TList;
  499.     FDataModules: TList;
  500.     FCursorList: PCursorRec;
  501.     FDefaultCursor: HCURSOR;
  502.     FActiveControl: TWinControl;
  503.     FActiveForm: TForm;
  504.     FLastActiveControl: TWinControl;
  505.     FLastActiveForm: TForm;
  506.     FFocusedForm: TForm;
  507.     FOnActiveControlChange: TNotifyEvent;
  508.     FOnActiveFormChange: TNotifyEvent;
  509.     procedure AddDataModule(DataModule: TDataModule);
  510.     procedure AddForm(AForm: TForm);
  511.     procedure CreateCursors;
  512.     procedure DeleteCursor(Index: Integer);
  513.     procedure DestroyCursors;
  514.     procedure InitImes;
  515.     function GetCursors(Index: Integer): HCURSOR;
  516.     function GetDataModule(Index: Integer): TDataModule;
  517.     function GetDataModuleCount: Integer;
  518.     function GetHeight: Integer;
  519.     function GetWidth: Integer;
  520.     function GetForm(Index: Integer): TForm;
  521.     function GetFormCount: Integer;
  522.     procedure InsertCursor(Index: Integer; Handle: HCURSOR);
  523.     procedure RemoveDataModule(DataModule: TDataModule);
  524.     procedure RemoveForm(AForm: TForm);
  525.     procedure SetCursors(Index: Integer; Handle: HCURSOR);
  526.     procedure SetCursor(Value: TCursor);
  527.     procedure UpdateLastActive;
  528.   public
  529.     constructor Create(AOwner: TComponent); override;
  530.     destructor Destroy; override;
  531.     property ActiveControl: TWinControl read FActiveControl;
  532.     property ActiveForm: TForm read FActiveForm;
  533.     property Cursor: TCursor read FCursor write SetCursor;
  534.     property Cursors[Index: Integer]: HCURSOR read GetCursors write SetCursors;
  535.     property DataModules[Index: Integer]: TDataModule read GetDataModule;
  536.     property DataModuleCount: Integer read GetDataModuleCount;
  537.     property Fonts: TStrings read FFonts;
  538.     property Height: Integer read GetHeight;
  539.     property Imes: TStrings read FImes;
  540.     property DefaultIme: string read FDefaultIme;
  541.     property DefaultKbLayout: HKL read FDefaultKbLayout;
  542.     property RestoreFocusForms: TList read FRestoreFocusForms write FRestoreFocusForms;
  543.     property PixelsPerInch: Integer read FPixelsPerInch;
  544.     property Width: Integer read GetWidth;
  545.     property Forms[Index: Integer]: TForm read GetForm;
  546.     property FormCount: Integer read GetFormCount;
  547.     property OnActiveControlChange: TNotifyEvent
  548.       read FOnActiveControlChange write FOnActiveControlChange;
  549.     property OnActiveFormChange: TNotifyEvent
  550.       read FOnActiveFormChange write FOnActiveFormChange;
  551.   end;
  552.  
  553. { TApplication }
  554.  
  555.   TTimerMode = (tmShow, tmHide);
  556.   THintInfo = record
  557.     HintControl: TControl;
  558.     HintPos: TPoint;
  559.     HintMaxWidth: Integer;
  560.     HintColor: TColor;
  561.     CursorRect: TRect;
  562.     CursorPos: TPoint;
  563.   end;
  564.  
  565.   TMessageEvent = procedure (var Msg: TMsg; var Handled: Boolean) of object;
  566.   TExceptionEvent = procedure (Sender: TObject; E: Exception) of object;
  567.   TIdleEvent = procedure (Sender: TObject; var Done: Boolean) of object;
  568.   TShowHintEvent = procedure (var HintStr: string; var CanShow: Boolean;
  569.     var HintInfo: THintInfo) of object;
  570.   TWindowHook = function (var Message: TMessage): Boolean of object;
  571.  
  572.   TApplication = class(TComponent)
  573.   private
  574.     FHandle: HWnd;
  575.     FObjectInstance: Pointer;
  576.     FMainForm: TForm;
  577.     FMouseControl: TControl;
  578.     FHelpFile: string;
  579.     FHint: string;
  580.     FHintActive: Boolean;
  581.     FUpdateFormatSettings: Boolean;
  582.     FShowMainForm: Boolean;
  583.     FHintColor: TColor;
  584.     FHintControl: TControl;
  585.     FHintCursorRect: TRect;
  586.     FHintPause: Integer;
  587.     FHintShortPause: Integer;
  588.     FHintHidePause: Integer;
  589.     FHintWindow: THintWindow;
  590.     FShowHint: Boolean;
  591.     FTimerActive: Boolean;
  592.     FTimerMode: TTimerMode;
  593.     FTimerHandle: Word;
  594.     FTitle: string;
  595.     FTopMostList: TList;
  596.     FTopMostLevel: Integer;
  597.     FIcon: TIcon;
  598.     FTerminate: Boolean;
  599.     FActive: Boolean;
  600.     FIgnoreFontProperty: Boolean;
  601.     FHandleCreated: Boolean;
  602.     FRunning: Boolean;
  603.     FWindowHooks: TList;
  604.     FWindowList: Pointer;
  605.     FDialogHandle: HWnd;
  606.     FOnException: TExceptionEvent;
  607.     FOnMessage: TMessageEvent;
  608.     FOnHelp: THelpEvent;
  609.     FOnHint: TNotifyEvent;
  610.     FOnIdle: TIdleEvent;
  611.     FOnDeactivate: TNotifyEvent;
  612.     FOnActivate: TNotifyEvent;
  613.     FOnShowHint: TShowHintEvent;
  614.     FOnMinimize: TNotifyEvent;
  615.     FOnRestore: TNotifyEvent;
  616.     procedure ActivateHint(CursorPos: TPoint);
  617.     function CheckIniChange(var Message: TMessage): Boolean;
  618.     function GetDialogHandle: HWND;
  619.     function GetExeName: string;
  620.     function GetIconHandle: HICON;
  621.     function GetTitle: string;
  622.     procedure HintTimerExpired;
  623.     procedure IconChanged(Sender: TObject);
  624.     procedure Idle;
  625.     function InvokeHelp(Command: Word; Data: Longint): Boolean;
  626.     function IsDlgMsg(var Msg: TMsg): Boolean;
  627.     function IsHintMsg(var Msg: TMsg): Boolean;
  628.     function IsKeyMsg(var Msg: TMsg): Boolean;
  629.     function IsMDIMsg(var Msg: TMsg): Boolean;
  630.     procedure NotifyForms(Msg: Word);
  631.     function ProcessMessage: Boolean;
  632.     procedure SetDialogHandle(Value: HWnd);
  633.     procedure SetHandle(Value: HWnd);
  634.     procedure SetHint(const Value: string);
  635.     procedure SetHintColor(Value: TColor);
  636.     procedure SetIcon(Value: TIcon);
  637.     procedure SetShowHint(Value: Boolean);
  638.     procedure SetTitle(const Value: string);
  639.     procedure StartHintTimer(Value: Integer; TimerMode: TTimerMode);
  640.     procedure StopHintTimer;
  641.     procedure WndProc(var Message: TMessage);
  642.   public
  643.     constructor Create(AOwner: TComponent); override;
  644.     destructor Destroy; override;
  645.     procedure BringToFront;
  646.     procedure ControlDestroyed(Control: TControl);
  647.     procedure CancelHint;
  648.     procedure CreateForm(InstanceClass: TComponentClass; var Reference);
  649.     procedure CreateHandle;
  650.     procedure HandleException(Sender: TObject);
  651.     procedure HandleMessage;
  652.     function HelpCommand(Command: Integer; Data: Longint): Boolean;
  653.     function HelpContext(Context: THelpContext): Boolean;
  654.     function HelpJump(const JumpID: string): Boolean;
  655.     procedure HideHint;
  656.     procedure HintMouseMessage(Control: TControl; var Message: TMessage);
  657.     procedure HookMainWindow(Hook: TWindowHook);
  658.     procedure Initialize;
  659.     function MessageBox(Text, Caption: PChar; Flags: Word): Integer;
  660.     procedure Minimize;
  661.     procedure NormalizeTopMosts;
  662.     procedure ProcessMessages;
  663.     procedure Restore;
  664.     procedure RestoreTopMosts;
  665.     procedure Run;
  666.     procedure ShowException(E: Exception);
  667.     procedure Terminate;
  668.     procedure UnhookMainWindow(Hook: TWindowHook);
  669.     property Active: Boolean read FActive;
  670.     property DialogHandle: HWnd read GetDialogHandle write SetDialogHandle;
  671.     property ExeName: string read GetExeName;
  672.     property Handle: HWnd read FHandle write SetHandle;
  673.     property HelpFile: string read FHelpFile write FHelpFile;
  674.     property Hint: string read FHint write SetHint;
  675.     property HintColor: TColor read FHintColor write SetHintColor;
  676.     property HintPause: Integer read FHintPause write FHintPause;
  677.     property HintShortPause: Integer read FHintShortPause write FHintShortPause;
  678.     property HintHidePause: Integer read FHintHidePause write FHintHidePause;
  679.     property Icon: TIcon read FIcon write SetIcon;
  680.     property IgnoreFontProperty: Boolean read FIgnoreFontProperty write FIgnoreFontProperty;
  681.     property MainForm: TForm read FMainForm;
  682.     property ShowHint: Boolean read FShowHint write SetShowHint;
  683.     property ShowMainForm: Boolean read FShowMainForm write FShowMainForm;
  684.     property Terminated: Boolean read FTerminate;
  685.     property Title: string read GetTitle write SetTitle;
  686.     property UpdateFormatSettings: Boolean read FUpdateFormatSettings
  687.       write FUpdateFormatSettings;
  688.     property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
  689.     property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
  690.     property OnException: TExceptionEvent read FOnException write FOnException;
  691.     property OnIdle: TIdleEvent read FOnIdle write FOnIdle;
  692.     property OnHelp: THelpEvent read FOnHelp write FOnHelp;
  693.     property OnHint: TNotifyEvent read FOnHint write FOnHint;
  694.     property OnMessage: TMessageEvent read FOnMessage write FOnMessage;
  695.     property OnMinimize: TNotifyEvent read FOnMinimize write FOnMinimize;
  696.     property OnRestore: TNotifyEvent read FOnRestore write FOnRestore;
  697.     property OnShowHint: TShowHintEvent read FOnShowHint write FOnShowHint;
  698.   end;
  699.  
  700.   TWndMethod = procedure(var Message: TMessage) of object;
  701.  
  702. { Global objects }
  703.  
  704. var
  705.   Application: TApplication;
  706.   Screen: TScreen;
  707.   Ctl3DBtnWndProc: Pointer = nil;
  708.   Ctl3DDlgFramePaint: function(Window: HWnd; Msg, wParam, lParam: Longint): Longint stdcall = nil;
  709.   Ctl3DCtlColorEx : function(Window: HWnd; Msg, wParam, lParam: Longint): Longint stdcall = nil;
  710.   HintWindowClass: THintWindowClass = THintWindow;
  711.  
  712. function GetParentForm(Control: TControl): TForm;
  713. function ValidParentForm(Control: TControl): TForm;
  714.  
  715. function DisableTaskWindows(ActiveWindow: HWnd): Pointer;
  716. procedure EnableTaskWindows(WindowList: Pointer);
  717.  
  718. function MakeObjectInstance(Method: TWndMethod): Pointer;
  719. procedure FreeObjectInstance(ObjectInstance: Pointer);
  720.  
  721. function IsAccel(VK: Word; const Str: string): Boolean;
  722.  
  723. function  Subclass3DWnd(Wnd: HWnd): Boolean;
  724. procedure Subclass3DDlg(Wnd: HWnd; Flags: Word);
  725. procedure SetAutoSubClass(Enable: Boolean);
  726. function AllocateHWnd(Method: TWndMethod): HWND;
  727. procedure DeallocateHWnd(Wnd: HWND);
  728. procedure DoneCtl3D;
  729. procedure InitCtl3D;
  730.  
  731. function KeysToShiftState(Keys: Word): TShiftState;
  732. function KeyDataToShiftState(KeyData: Longint): TShiftState;
  733.  
  734. implementation
  735.  
  736. uses Printers, Consts;
  737.  
  738. var
  739.   FocusMessages: Boolean = True;
  740.   FocusCount: Integer = 0;
  741.  
  742. const
  743.   DefHintColor = clInfoBk;  { default hint window color }
  744.   DefHintPause = 500;      { default pause before hint window displays (ms)}
  745.   DefHintShortPause = DefHintPause div 10;
  746.   DefHintHidePause = DefHintPause * 5;
  747.  
  748. {$I VCL.INC}
  749.  
  750. function Max(X, Y: Integer): Integer;
  751. begin
  752.   Result := X;
  753.   if Y > X then Result := Y;
  754. end;
  755.  
  756. { Task window management }
  757.  
  758. type
  759.   PTaskWindow = ^TTaskWindow;
  760.   TTaskWindow = record
  761.     Next: PTaskWindow;
  762.     Window: HWnd;
  763.   end;
  764.  
  765. var
  766.   TaskActiveWindow: HWnd = 0;
  767.   TaskFirstWindow: HWnd = 0;
  768.   TaskFirstTopMost: HWnd = 0;
  769.   TaskWindowList: PTaskWindow = nil;
  770.  
  771. procedure DoneApplication; far;
  772. begin
  773.   with Application do
  774.   begin
  775.     if Handle <> 0 then ShowOwnedPopups(Handle, False);
  776.     Destroying;
  777.     DestroyComponents;
  778.   end;
  779. end;
  780.  
  781. function DoDisableWindow(Window: HWnd; Data: Longint): WordBool; stdcall;
  782. var
  783.   P: PTaskWindow;
  784. begin
  785.   if (Window <> TaskActiveWindow) and IsWindowVisible(Window) and
  786.     IsWindowEnabled(Window) then
  787.   begin
  788.     New(P);
  789.     P^.Next := TaskWindowList;
  790.     P^.Window := Window;
  791.     TaskWindowList := P;
  792.     EnableWindow(Window, False);
  793.   end;
  794.   Result := True;
  795. end;
  796.  
  797. function DisableTaskWindows(ActiveWindow: HWnd): Pointer;
  798. var
  799.   SaveActiveWindow: HWND;
  800.   SaveWindowList: Pointer;
  801. begin
  802.   Result := nil;
  803.   SaveActiveWindow := TaskActiveWindow;
  804.   SaveWindowList := TaskWindowList;
  805.   TaskActiveWindow := ActiveWindow;
  806.   TaskWindowList := nil;
  807.   try
  808.     try
  809.       EnumThreadWindows(GetCurrentThreadID, @DoDisableWindow, 0);
  810.       Result := TaskWindowList;
  811.     except
  812.       EnableTaskWindows(TaskWindowList);
  813.       raise;
  814.     end;
  815.   finally
  816.     TaskWindowList := SaveWindowList;
  817.     TaskActiveWindow := SaveActiveWindow;
  818.   end;
  819. end;
  820.  
  821. procedure EnableTaskWindows(WindowList: Pointer);
  822. var
  823.   P: PTaskWindow;
  824. begin
  825.   while WindowList <> nil do
  826.   begin
  827.     P := WindowList;
  828.     if IsWindow(P^.Window) then EnableWindow(P^.Window, True);
  829.     WindowList := P^.Next;
  830.     Dispose(P);
  831.   end;
  832. end;
  833.  
  834. function DoFindWindow(Window: HWnd; Param: Longint): WordBool; stdcall;
  835. begin
  836.   if (Window <> TaskActiveWindow) and (Window <> Application.FHandle) and
  837.     IsWindowVisible(Window) and IsWindowEnabled(Window) then
  838.     if GetWindowLong(Window, GWL_EXSTYLE) and WS_EX_TOPMOST = 0 then
  839.     begin
  840.       if TaskFirstWindow = 0 then TaskFirstWindow := Window;
  841.     end else
  842.     begin
  843.       if TaskFirstTopMost = 0 then TaskFirstTopMost := Window;
  844.     end;
  845.   Result := True;
  846. end;
  847.  
  848. function FindTopMostWindow(ActiveWindow: HWnd): HWnd;
  849. begin
  850.   TaskActiveWindow := ActiveWindow;
  851.   TaskFirstWindow := 0;
  852.   TaskFirstTopMost := 0;
  853.   EnumThreadWindows(GetCurrentThreadID, @DoFindWindow, 0);
  854.   if TaskFirstWindow <> 0 then
  855.     Result := TaskFirstWindow else
  856.     Result := TaskFirstTopMost;
  857. end;
  858.  
  859. function SendFocusMessage(Window: HWnd; Msg: Word): Boolean;
  860. var
  861.   Count: Integer;
  862. begin
  863.   Count := FocusCount;
  864.   SendMessage(Window, Msg, 0, 0);
  865.   Result := FocusCount = Count;
  866. end;
  867.  
  868. { Check if this is the active Windows task }
  869.  
  870. type
  871.   PCheckTaskInfo = ^TCheckTaskInfo;
  872.   TCheckTaskInfo = record
  873.     FocusWnd: HWnd;
  874.     Found: Boolean;
  875.   end;
  876.  
  877. function CheckTaskWindow(Window: HWnd; Data: Longint): WordBool; stdcall;
  878. begin
  879.   Result := True;
  880.   if PCheckTaskInfo(Data)^.FocusWnd = Window then
  881.   begin
  882.     Result := False;
  883.     PCheckTaskInfo(Data)^.Found := True;
  884.   end;
  885. end;
  886.  
  887. function ForegroundTask: Boolean;
  888. var
  889.   Info: TCheckTaskInfo;
  890. begin
  891.   Info.FocusWnd := GetActiveWindow;
  892.   Info.Found := False;
  893.   EnumThreadWindows(GetCurrentThreadID, @CheckTaskWindow, Longint(@Info));
  894.   Result := Info.Found;
  895. end;
  896.  
  897. function FindGlobalComponent(const Name: string): TComponent;
  898. var
  899.   I: Integer;
  900. begin
  901.   for I := 0 to Screen.FormCount - 1 do
  902.   begin
  903.     Result := Screen.Forms[I];
  904.     if CompareText(Name, Result.Name) = 0 then Exit;
  905.   end;
  906.   for I := 0 to Screen.DataModuleCount - 1 do
  907.   begin
  908.     Result := Screen.DataModules[I];
  909.     if CompareText(Name, Result.Name) = 0 then Exit;
  910.   end;
  911.   Result := nil;
  912. end;
  913.  
  914. { CTL3D32.DLL support }
  915.  
  916. var
  917.   Ctl3DHandle: THandle = 0;
  918.  
  919. const
  920.   Ctl3DLib = 'CTL3D32.DLL';
  921. var
  922.   Ctl3DRegister: function(Instance: THandle): Bool stdcall;
  923.   Ctl3DUnregister: function(Instance: THandle): Bool stdcall;
  924.   Ctl3DSubclassCtl: function(Wnd: HWnd): Bool stdcall;
  925.   Ctl3DSubclassDlg: function(Wnd: HWnd; Flags: Word): Bool stdcall;
  926.   Ctl3DAutoSubclass: function(Instance: THandle): Bool stdcall;
  927.   Ctl3DUnAutoSubclass: function: Bool stdcall;
  928.   Ctl3DColorChange: function: Bool stdcall;
  929.  
  930. procedure InitCtl3D;
  931. var
  932.   ErrMode: Word;
  933.   Version: Longint;
  934. begin
  935.   if Ctl3DHandle = 0 then
  936.   begin
  937.     Version := GetVersion;
  938.     if (LoByte(LoWord(Version)) < 4) and (HiByte(LoWord(Version)) < $59) then
  939.     begin
  940.       ErrMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);
  941.       Ctl3DHandle := LoadLibrary(Ctl3DLib);
  942.       SetErrorMode(ErrMode);
  943.     end;
  944.     if Ctl3DHandle < 32 then Ctl3DHandle := 1;
  945.     if Ctl3DHandle >= 32 then
  946.     begin
  947.       @Ctl3DRegister := GetProcAddress(Ctl3DHandle, 'Ctl3dRegister');
  948.       if Ctl3DRegister(HInstance) then
  949.       begin
  950.         @Ctl3DUnregister := GetProcAddress(Ctl3DHandle, 'Ctl3dUnregister');
  951.         @Ctl3DSubclassCtl := GetProcAddress(Ctl3DHandle, 'Ctl3dSubclassCtl');
  952.         @Ctl3DSubclassDlg := GetProcAddress(Ctl3DHandle, 'Ctl3dSubclassDlgEx');
  953.         @Ctl3DDlgFramePaint := GetProcAddress(Ctl3DHandle, 'Ctl3dDlgFramePaint');
  954.         @Ctl3DCtlColorEx := GetProcAddress(Ctl3DHandle, 'Ctl3dCtlColorEx');
  955.         @Ctl3DAutoSubclass := GetProcAddress(Ctl3DHandle, 'Ctl3dAutoSubclass');
  956.         @Ctl3DUnAutoSubclass := GetProcAddress(Ctl3DHandle, 'Ctl3dUnAutoSubclass');
  957.         @Ctl3DColorChange := GetProcAddress(Ctl3DHandle, 'Ctl3DColorChange');
  958.         Ctl3DBtnWndProc := GetProcAddress(Ctl3DHandle, 'BtnWndProc3d');
  959.       end
  960.       else
  961.       begin
  962.         FreeLibrary(Ctl3DHandle);
  963.         Ctl3DHandle := 1;
  964.       end;
  965.     end;
  966.   end;
  967. end;
  968.  
  969. procedure DoneCtl3D;
  970. begin
  971.   if Ctl3DHandle >= 32 then
  972.   begin
  973.     Ctl3DUnregister(HInstance);
  974.     FreeLibrary(Ctl3DHandle);
  975.   end;
  976. end;
  977.  
  978. function Subclass3DWnd(Wnd: HWnd): Boolean;
  979. begin
  980.   Result := False;
  981.   if Ctl3DHandle = 0 then InitCtl3D;
  982.   if Ctl3DHandle >= 32 then
  983.     Result := Ctl3DSubclassCtl(Wnd);
  984. end;
  985.  
  986. procedure Subclass3DDlg(Wnd: HWnd; Flags: Word);
  987. begin
  988.   if Ctl3DHandle = 0 then InitCtl3D;
  989.   if Ctl3DHandle >= 32 then Ctl3DSubclassDlg(Wnd, Flags);
  990. end;
  991.  
  992. procedure SetAutoSubClass(Enable: Boolean);
  993. begin
  994.   if Ctl3DHandle = 0 then InitCtl3D;
  995.   if Ctl3DHandle >= 32 then
  996.     if (@Ctl3DAutoSubclass = nil) or (@Ctl3DUnAutoSubclass = nil) then
  997.       Exit
  998.     else if Enable then
  999.       Ctl3DAutoSubclass(HInstance)
  1000.     else Ctl3dUnAutoSubclass;
  1001. end;
  1002.  
  1003. const
  1004.   InstanceCount = 313;
  1005.  
  1006. { Object instance management }
  1007.  
  1008. type
  1009.   PObjectInstance = ^TObjectInstance;
  1010.   TObjectInstance = packed record
  1011.     Code: Byte;
  1012.     Offset: Integer;
  1013.     case Integer of
  1014.       0: (Next: PObjectInstance);
  1015.       1: (Method: TWndMethod);
  1016.   end;
  1017.  
  1018. type
  1019.   PInstanceBlock = ^TInstanceBlock;
  1020.   TInstanceBlock = packed record
  1021.     Next: PInstanceBlock;
  1022.     Code: array[1..2] of Byte;
  1023.     WndProcPtr: Pointer;
  1024.     Instances: array[0..InstanceCount] of TObjectInstance;
  1025.   end;
  1026.  
  1027. var
  1028.   InstBlockList: PInstanceBlock;
  1029.   InstFreeList: PObjectInstance;
  1030.  
  1031. { Standard window procedure }
  1032. { In    ECX = Address of method pointer }
  1033. { Out   EAX = Result }
  1034.  
  1035. function StdWndProc(Window: HWND; Message, WParam: Longint;
  1036.   LParam: Longint): Longint; stdcall; assembler;
  1037. asm
  1038.         XOR     EAX,EAX
  1039.         PUSH    EAX
  1040.         PUSH    LParam
  1041.         PUSH    WParam
  1042.         PUSH    Message
  1043.         MOV     EDX,ESP
  1044.         MOV     EAX,[ECX].Longint[4]
  1045.         CALL    [ECX].Pointer
  1046.         ADD     ESP,12
  1047.         POP     EAX
  1048. end;
  1049.  
  1050. { Allocate an object instance }
  1051.  
  1052. function CalcJmpOffset(Src, Dest: Pointer): Longint;
  1053. begin
  1054.   Result := Longint(Dest) - (Longint(Src) + 5);
  1055. end;
  1056.  
  1057. function MakeObjectInstance(Method: TWndMethod): Pointer;
  1058. const
  1059.   BlockCode: array[1..2] of Byte = (
  1060.     $59,       { POP ECX }
  1061.     $E9);      { JMP StdWndProc }
  1062.   PageSize = 4096;
  1063. var
  1064.   Block: PInstanceBlock;
  1065.   Instance: PObjectInstance;
  1066. begin
  1067.   if InstFreeList = nil then
  1068.   begin
  1069.     Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
  1070.     Block^.Next := InstBlockList;
  1071.     Move(BlockCode, Block^.Code, SizeOf(BlockCode));
  1072.     Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc));
  1073.     Instance := @Block^.Instances;
  1074.     repeat
  1075.       Instance^.Code := $E8;  { CALL NEAR PTR Offset }
  1076.       Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);
  1077.       Instance^.Next := InstFreeList;
  1078.       InstFreeList := Instance;
  1079.       Inc(Longint(Instance), SizeOf(TObjectInstance));
  1080.     until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);
  1081.     InstBlockList := Block;
  1082.   end;
  1083.   Result := InstFreeList;
  1084.   Instance := InstFreeList;
  1085.   InstFreeList := Instance^.Next;
  1086.   Instance^.Method := Method;
  1087. end;
  1088.  
  1089. { Free an object instance }
  1090.  
  1091. procedure FreeObjectInstance(ObjectInstance: Pointer);
  1092. begin
  1093.   if ObjectInstance <> nil then
  1094.   begin
  1095.     PObjectInstance(ObjectInstance)^.Next := InstFreeList;
  1096.     InstFreeList := ObjectInstance;
  1097.   end;
  1098. end;
  1099.  
  1100. var
  1101.   UtilWindowClass: TWndClass = (
  1102.     style: 0;
  1103.     lpfnWndProc: @DefWindowProc;
  1104.     cbClsExtra: 0;
  1105.     cbWndExtra: 0;
  1106.     hInstance: 0;
  1107.     hIcon: 0;
  1108.     hCursor: 0;
  1109.     hbrBackground: 0;
  1110.     lpszMenuName: nil;
  1111.     lpszClassName: 'TPUtilWindow');
  1112.  
  1113. function AllocateHWnd(Method: TWndMethod): HWND;
  1114. var
  1115.   TempClass: TWndClass;
  1116.   ClassRegistered: Boolean;
  1117. begin
  1118.   UtilWindowClass.hInstance := HInstance;
  1119.   ClassRegistered := GetClassInfo(HInstance, UtilWindowClass.lpszClassName,
  1120.     TempClass);
  1121.   if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then
  1122.   begin
  1123.     if ClassRegistered then
  1124.       Windows.UnregisterClass(UtilWindowClass.lpszClassName, HInstance);
  1125.     Windows.RegisterClass(UtilWindowClass);
  1126.   end;
  1127.   Result := CreateWindow(UtilWindowClass.lpszClassName, '', 0,
  1128.     0, 0, 0, 0, 0, 0, HInstance, nil);
  1129.   SetWindowLong(Result, GWL_WNDPROC, Longint(MakeObjectInstance(Method)));
  1130. end;
  1131.  
  1132. procedure DeallocateHWnd(Wnd: HWND);
  1133. var
  1134.   Instance: Pointer;
  1135. begin
  1136.   Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC));
  1137.   DestroyWindow(Wnd);
  1138.   FreeObjectInstance(Instance);
  1139. end;
  1140.  
  1141. { Utility mapping functions }
  1142.  
  1143. { Convert mouse message to TMouseButton }
  1144.  
  1145. function KeysToShiftState(Keys: Word): TShiftState;
  1146. begin
  1147.   Result := [];
  1148.   if Keys and MK_SHIFT <> 0 then Include(Result, ssShift);
  1149.   if Keys and MK_CONTROL <> 0 then Include(Result, ssCtrl);
  1150.   if Keys and MK_LBUTTON <> 0 then Include(Result, ssLeft);
  1151.   if Keys and MK_RBUTTON <> 0 then Include(Result, ssRight);
  1152.   if Keys and MK_MBUTTON <> 0 then Include(Result, ssMiddle);
  1153.   if GetKeyState(VK_MENU) < 0 then Include(Result, ssAlt);
  1154. end;
  1155.  
  1156. { Convert keyboard message data to TShiftState }
  1157.  
  1158. function KeyDataToShiftState(KeyData: Longint): TShiftState;
  1159. const
  1160.   AltMask = $20000000;
  1161. begin
  1162.   Result := [];
  1163.   if GetKeyState(VK_SHIFT) < 0 then Include(Result, ssShift);
  1164.   if GetKeyState(VK_CONTROL) < 0 then Include(Result, ssCtrl);
  1165.   if KeyData and AltMask <> 0 then Include(Result, ssAlt);
  1166. end;
  1167.  
  1168. function IsAccel(VK: Word; const Str: string): Boolean;
  1169. var
  1170.   P: Integer;
  1171. begin
  1172.   P := Pos('&', Str);
  1173.   Result := (P <> 0) and (P < Length(Str)) and
  1174.     (AnsiCompareText(Str[P + 1], Char(VK)) = 0);
  1175. end;
  1176.  
  1177. { Form utility functions }
  1178.  
  1179. function GetParentForm(Control: TControl): TForm;
  1180. begin
  1181.   while Control.Parent <> nil do Control := Control.Parent;
  1182.   Result := nil;
  1183.   if Control is TForm then Result := TForm(Control);
  1184. end;
  1185.  
  1186. function ValidParentForm(Control: TControl): TForm;
  1187. begin
  1188.   Result := GetParentForm(Control);
  1189.   if Result = nil then
  1190.     raise EInvalidOperation.CreateResFmt(SParentRequired, [Control.Name]);
  1191. end;
  1192.  
  1193. { TDesigner }
  1194.  
  1195. function TDesigner.GetIsControl: Boolean;
  1196. begin
  1197.   Result := (FForm <> nil) and FForm.IsControl;
  1198. end;
  1199.  
  1200. procedure TDesigner.SetIsControl(Value: Boolean);
  1201. begin
  1202.   if (FForm <> nil) then FForm.IsControl := Value;
  1203. end;
  1204.  
  1205. { TControlScrollBar }
  1206.  
  1207. constructor TControlScrollBar.Create(AControl: TScrollingWinControl;
  1208.   AKind: TScrollBarKind);
  1209. begin
  1210.   inherited Create;
  1211.   FControl := AControl;
  1212.   FKind := AKind;
  1213.   FIncrement := 8;
  1214.   FVisible := True;
  1215. end;
  1216.  
  1217. procedure TControlScrollBar.Assign(Source: TPersistent);
  1218. begin
  1219.   if Source is TControlScrollBar then
  1220.   begin
  1221.     Visible := TControlScrollBar(Source).Visible;
  1222.     Range := TControlScrollBar(Source).Range;
  1223.     Position := TControlScrollBar(Source).Position;
  1224.     Increment := TControlScrollBar(Source).Increment;
  1225.     Exit;
  1226.   end;
  1227.   inherited Assign(Source);
  1228. end;
  1229.  
  1230. procedure TControlScrollBar.CalcAutoRange;
  1231. var
  1232.   I: Integer;
  1233.   NewRange, AlignMargin: Integer;
  1234.  
  1235.   procedure ProcessHorz(Control: TControl);
  1236.   begin
  1237.     if Control.Visible then
  1238.       case TForm(Control).Align of
  1239.         alNone: NewRange := Max(NewRange, Position + Control.Left + Control.Width);
  1240.         alRight: Inc(AlignMargin, Control.Width);
  1241.       end;
  1242.   end;
  1243.  
  1244.   procedure ProcessVert(Control: TControl);
  1245.   begin
  1246.     if Control.Visible then
  1247.       case TForm(Control).Align of
  1248.         alNone: NewRange := Max(NewRange, Position + Control.Top + Control.Height);
  1249.         alBottom: Inc(AlignMargin, Control.Height);
  1250.       end;
  1251.   end;
  1252.  
  1253. begin
  1254.   if FControl.FAutoScroll then
  1255.   begin
  1256.     NewRange := 0;
  1257.     AlignMargin := 0;
  1258.     for I := 0 to FControl.ControlCount - 1 do
  1259.       if Kind = sbHorizontal then
  1260.         ProcessHorz(FControl.Controls[I]) else
  1261.         ProcessVert(FControl.Controls[I]);
  1262.     DoSetRange(NewRange + AlignMargin + Margin);
  1263.   end;
  1264. end;
  1265.  
  1266. function TControlScrollBar.ControlSize(ControlSB, AssumeSB: Boolean): Integer;
  1267. var
  1268.   BorderAdjust: Integer;
  1269.  
  1270.   function ScrollBarVisible(Code: Word): Boolean;
  1271.   var
  1272.     Style: Longint;
  1273.   begin
  1274.     Style := WS_HSCROLL;
  1275.     if Code = SB_VERT then Style := WS_VSCROLL;
  1276.     Result := GetWindowLong(FControl.Handle, GWL_STYLE) and Style <> 0;
  1277.   end;
  1278.  
  1279.   function Adjustment(Code, Metric: Word): Integer;
  1280.   begin
  1281.     Result := 0;
  1282.     if not ControlSB then
  1283.       if AssumeSB and not ScrollBarVisible(Code) then
  1284.         Result := -(GetSystemMetrics(Metric) - BorderAdjust)
  1285.       else if not AssumeSB and ScrollBarVisible(Code) then
  1286.         Result := GetSystemMetrics(Metric) - BorderAdjust;
  1287.   end;
  1288.  
  1289. begin
  1290.   BorderAdjust := Integer(GetWindowLong(FControl.Handle, GWL_STYLE) and
  1291.     (WS_BORDER or WS_THICKFRAME) <> 0);
  1292.   if Kind = sbVertical then
  1293.     Result := FControl.ClientHeight + Adjustment(SB_HORZ, SM_CXHSCROLL) else
  1294.     Result := FControl.ClientWidth + Adjustment(SB_VERT, SM_CYVSCROLL);
  1295. end;
  1296.  
  1297. function TControlScrollBar.GetScrollPos: Integer;
  1298. begin
  1299.   Result := 0;
  1300.   if Visible then Result := Position;
  1301. end;
  1302.  
  1303. function TControlScrollBar.NeedsScrollBarVisible: Boolean;
  1304. begin
  1305.   Result := FRange > ControlSize(False, False);
  1306. end;
  1307.  
  1308. procedure TControlScrollBar.ScrollMessage(var Msg: TWMScroll);
  1309. begin
  1310.   with Msg do
  1311.     case ScrollCode of
  1312.       SB_LINEUP: SetPosition(FPosition - FIncrement);
  1313.       SB_LINEDOWN: SetPosition(FPosition + FIncrement);
  1314.       SB_PAGEUP: SetPosition(FPosition - ControlSize(True, False));
  1315.       SB_PAGEDOWN: SetPosition(FPosition + ControlSize(True, False));
  1316.       SB_THUMBPOSITION: SetPosition(Pos);
  1317.       SB_THUMBTRACK: if Tracking then SetPosition(Pos);
  1318.       SB_TOP: SetPosition(0);
  1319.       SB_BOTTOM: SetPosition(FCalcRange);
  1320.       SB_ENDSCROLL: begin end;
  1321.     end;
  1322. end;
  1323.  
  1324. procedure TControlScrollBar.SetPosition(Value: Integer);
  1325. var
  1326.   Code: Word;
  1327.   Form: TForm;
  1328.   OldPos: Integer;
  1329. begin
  1330.   if csReading in FControl.ComponentState then
  1331.     FPosition := Value
  1332.   else
  1333.   begin
  1334.     if Value > FCalcRange then Value := FCalcRange
  1335.     else if Value < 0 then Value := 0;
  1336.     if Kind = sbHorizontal then
  1337.       Code := SB_HORZ else
  1338.       Code := SB_VERT;
  1339.     if Value <> FPosition then
  1340.     begin
  1341.       OldPos := FPosition;
  1342.       FPosition := Value;
  1343.       if Kind = sbHorizontal then
  1344.         FControl.ScrollBy(OldPos - Value, 0) else
  1345.         FControl.ScrollBy(0, OldPos - Value);
  1346.       if csDesigning in FControl.ComponentState then
  1347.       begin
  1348.         Form := GetParentForm(FControl);
  1349.         if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified;
  1350.       end;
  1351.     end;
  1352.     if Windows.GetScrollPos(FControl.Handle, Code) <> FPosition then
  1353.       SetScrollPos(FControl.Handle, Code, FPosition, True);
  1354.   end;
  1355. end;
  1356.  
  1357. procedure TControlScrollBar.DoSetRange(Value: Integer);
  1358. begin
  1359.   FRange := Value;
  1360.   if FRange < 0 then FRange := 0;
  1361.   FControl.UpdateScrollBars;
  1362. end;
  1363.  
  1364. procedure TControlScrollBar.SetRange(Value: Integer);
  1365. begin
  1366.   FControl.FAutoScroll := False;
  1367.   FScaled := True;
  1368.   DoSetRange(Value);
  1369. end;
  1370.  
  1371. function TControlScrollBar.IsRangeStored: Boolean;
  1372. begin
  1373.   Result := not FControl.AutoScroll;
  1374. end;
  1375.  
  1376. procedure TControlScrollBar.SetVisible(Value: Boolean);
  1377. begin
  1378.   FVisible := Value;
  1379.   FControl.UpdateScrollBars;
  1380. end;
  1381.  
  1382. procedure TControlScrollBar.Update(ControlSB, AssumeSB: Boolean);
  1383. var
  1384.   Code: Word;
  1385.   ScrollInfo: TScrollInfo;
  1386. begin
  1387.   FCalcRange := 0;
  1388.   Code := SB_HORZ;
  1389.   if Kind = sbVertical then Code := SB_VERT;
  1390.   if Visible then
  1391.   begin
  1392.     FCalcRange := Range - ControlSize(ControlSB, AssumeSB);
  1393.     if FCalcRange < 0 then FCalcRange := 0;
  1394.   end;
  1395.   ScrollInfo.cbSize := SizeOf(ScrollInfo);
  1396.   ScrollInfo.fMask := SIF_ALL;
  1397.   ScrollInfo.nMin := 0;
  1398.   if FCalcRange > 0 then
  1399.     ScrollInfo.nMax := Range else
  1400.     ScrollInfo.nMax := 0;
  1401.   ScrollInfo.nPage := ControlSize(ControlSB, AssumeSB) + 1;
  1402.   ScrollInfo.nPos := FPosition;
  1403.   ScrollInfo.nTrackPos := FPosition;
  1404.   SetScrollInfo(FControl.Handle, Code, ScrollInfo, True);
  1405.   SetPosition(FPosition);
  1406. end;
  1407.  
  1408. { TScrollingWinControl }
  1409.  
  1410. constructor TScrollingWinControl.Create(AOwner: TComponent);
  1411. begin
  1412.   inherited Create(AOwner);
  1413.   FHorzScrollBar := TControlScrollBar.Create(Self, sbHorizontal);
  1414.   FVertScrollBar := TControlScrollBar.Create(Self, sbVertical);
  1415.   FAutoScroll := True;
  1416. end;
  1417.  
  1418. destructor TScrollingWinControl.Destroy;
  1419. begin
  1420.   FHorzScrollBar.Free;
  1421.   FVertScrollBar.Free;
  1422.   inherited Destroy;
  1423. end;
  1424.  
  1425. procedure TScrollingWinControl.CreateWnd;
  1426. begin
  1427.   inherited CreateWnd;
  1428.   UpdateScrollBars;
  1429. end;
  1430.  
  1431. procedure TScrollingWinControl.AlignControls(AControl: TControl; var ARect: TRect);
  1432. begin
  1433.   CalcAutoRange;
  1434.   ARect := Bounds(-HorzScrollBar.Position, -VertScrollBar.Position,
  1435.     Max(HorzScrollBar.Range, ClientWidth), Max(ClientHeight, VertScrollBar.Range));
  1436.   inherited AlignControls(AControl, ARect);
  1437. end;
  1438.  
  1439. procedure TScrollingWinControl.CalcAutoRange;
  1440. begin
  1441.   if not FSizing then
  1442.   begin
  1443.     HorzScrollBar.CalcAutoRange;
  1444.     VertScrollBar.CalcAutoRange;
  1445.   end;
  1446. end;
  1447.  
  1448. procedure TScrollingWinControl.SetAutoScroll(Value: Boolean);
  1449. begin
  1450.   if FAutoScroll <> Value then
  1451.   begin
  1452.     FAutoScroll := Value;
  1453.     if Value then CalcAutoRange else
  1454.     begin
  1455.       HorzScrollBar.Range := 0;
  1456.       VertScrollBar.Range := 0;
  1457.     end;
  1458.   end;
  1459. end;
  1460.  
  1461. procedure TScrollingWinControl.SetHorzScrollBar(Value: TControlScrollBar);
  1462. begin
  1463.   FHorzScrollBar.Assign(Value);
  1464. end;
  1465.  
  1466. procedure TScrollingWinControl.SetVertScrollBar(Value: TControlScrollBar);
  1467. begin
  1468.   FVertScrollBar.Assign(Value);
  1469. end;
  1470.  
  1471. procedure TScrollingWinControl.UpdateScrollBars;
  1472. begin
  1473.   if not FUpdatingScrollBars and HandleAllocated then
  1474.     try
  1475.       FUpdatingScrollBars := True;
  1476.       if FVertScrollBar.NeedsScrollBarVisible then
  1477.       begin
  1478.         FHorzScrollBar.Update(False, True);
  1479.         FVertScrollBar.Update(True, False);
  1480.       end
  1481.       else if FHorzScrollBar.NeedsScrollBarVisible then
  1482.       begin
  1483.         FVertScrollBar.Update(False, True);
  1484.         FHorzScrollBar.Update(True, False);
  1485.       end
  1486.       else
  1487.       begin
  1488.         FVertScrollBar.Update(False, False);
  1489.         FHorzScrollBar.Update(True, False);
  1490.       end;
  1491.     finally
  1492.       FUpdatingScrollBars := False;
  1493.     end;
  1494. end;
  1495.  
  1496. procedure TScrollingWinControl.AutoScrollInView(AControl: TControl);
  1497. begin
  1498.   if (AControl <> nil) and not (csLoading in AControl.ComponentState) and
  1499.     not (csLoading in ComponentState) then
  1500.     ScrollInView(AControl);
  1501. end;
  1502.  
  1503. procedure TScrollingWinControl.ScrollInView(AControl: TControl);
  1504. var
  1505.   Rect: TRect;
  1506. begin
  1507.   if AControl = nil then Exit;
  1508.   Rect := AControl.ClientRect;
  1509.   Dec(Rect.Left, HorzScrollBar.Margin);
  1510.   Inc(Rect.Right, HorzScrollBar.Margin);
  1511.   Dec(Rect.Top, VertScrollBar.Margin);
  1512.   Inc(Rect.Bottom, VertScrollBar.Margin);
  1513.   Rect.TopLeft := ScreenToClient(AControl.ClientToScreen(Rect.TopLeft));
  1514.   Rect.BottomRight := ScreenToClient(AControl.ClientToScreen(Rect.BottomRight));
  1515.   if Rect.Left < 0 then
  1516.     with HorzScrollBar do Position := Position + Rect.Left
  1517.   else if Rect.Right > ClientWidth then
  1518.   begin
  1519.     if Rect.Right - Rect.Left > ClientWidth then
  1520.       Rect.Right := Rect.Left + ClientWidth;
  1521.     with HorzScrollBar do Position := Position + Rect.Right - ClientWidth;
  1522.   end;
  1523.   if Rect.Top < 0 then
  1524.     with VertScrollBar do Position := Position + Rect.Top
  1525.   else if Rect.Bottom > ClientHeight then
  1526.   begin
  1527.     if Rect.Bottom - Rect.Top > ClientHeight then
  1528.       Rect.Bottom := Rect.Top + ClientHeight;
  1529.     with VertScrollBar do Position := Position + Rect.Bottom - ClientHeight;
  1530.   end;
  1531. end;
  1532.  
  1533. procedure TScrollingWinControl.ScaleScrollBars(M, D: Integer);
  1534. begin
  1535.   if M <> D then
  1536.   begin
  1537.     if not (csLoading in ComponentState) then
  1538.     begin
  1539.       HorzScrollBar.FScaled := True;
  1540.       VertScrollBar.FScaled := True;
  1541.     end;
  1542.     HorzScrollBar.Position := 0;
  1543.     VertScrollBar.Position := 0;
  1544.     if not FAutoScroll then
  1545.     begin
  1546.       with HorzScrollBar do if FScaled then Range := MulDiv(Range, M, D);
  1547.       with VertScrollBar do if FScaled then Range := MulDiv(Range, M, D);
  1548.     end;
  1549.   end;
  1550.   HorzScrollBar.FScaled := False;
  1551.   VertScrollBar.FScaled := False;
  1552. end;
  1553.  
  1554. procedure TScrollingWinControl.ChangeScale(M, D: Integer);
  1555. begin
  1556.   ScaleScrollBars(M, D);
  1557.   inherited ChangeScale(M, D);
  1558. end;
  1559.  
  1560. procedure TScrollingWinControl.WMSize(var Message: TWMSize);
  1561. begin
  1562.   FSizing := True;
  1563.   try
  1564.     inherited;
  1565.   finally
  1566.     FSizing := False;
  1567.   end;
  1568.   UpdateScrollBars;
  1569. end;
  1570.  
  1571. procedure TScrollingWinControl.WMHScroll(var Message: TWMHScroll);
  1572. begin
  1573.   if Message.ScrollBar = 0 then
  1574.     FHorzScrollBar.ScrollMessage(Message) else
  1575.     inherited;
  1576. end;
  1577.  
  1578. procedure TScrollingWinControl.WMVScroll(var Message: TWMVScroll);
  1579. begin
  1580.   if Message.ScrollBar = 0 then
  1581.     FVertScrollBar.ScrollMessage(Message) else
  1582.     inherited;
  1583. end;
  1584.  
  1585. { TScrollBox }
  1586.  
  1587. constructor TScrollBox.Create(AOwner: TComponent);
  1588. begin
  1589.   inherited Create(AOwner);
  1590.   ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
  1591.     csSetCaption, csDoubleClicks];
  1592.   Width := 185;
  1593.   Height := 41;
  1594.   FBorderStyle := bsSingle;
  1595. end;
  1596.  
  1597. procedure TScrollBox.CreateParams(var Params: TCreateParams);
  1598. const
  1599.   BorderStyles: array[TBorderStyle] of Longint = (0, WS_BORDER);
  1600. begin
  1601.   inherited CreateParams(Params);
  1602.   with Params do
  1603.   begin
  1604.     Style := Style or BorderStyles[FBorderStyle];
  1605.     WindowClass.style := WindowClass.style or CS_HREDRAW or CS_VREDRAW;
  1606.     if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then
  1607.     begin
  1608.       Style := Style and not WS_BORDER;
  1609.       ExStyle := ExStyle or WS_EX_CLIENTEDGE;
  1610.     end;
  1611.   end;
  1612. end;
  1613.  
  1614. procedure TScrollBox.Resize;
  1615. begin
  1616.   if Assigned(FOnResize) then FOnResize(Self);
  1617. end;
  1618.  
  1619. procedure TScrollBox.SetBorderStyle(Value: TBorderStyle);
  1620. begin
  1621.   if Value <> FBorderStyle then
  1622.   begin
  1623.     FBorderStyle := Value;
  1624.     RecreateWnd;
  1625.   end;
  1626. end;
  1627.  
  1628. procedure TScrollBox.WMSize(var Message: TWMSize);
  1629. begin
  1630.   inherited;
  1631.   if not (csLoading in ComponentState) then Resize;
  1632.   CalcAutoRange;
  1633. end;
  1634.  
  1635. procedure TScrollBox.WMNCHitTest(var Message: TMessage);
  1636. begin
  1637.   DefaultHandler(Message);
  1638. end;
  1639.  
  1640. procedure TScrollBox.CMCtl3DChanged(var Message: TMessage);
  1641. begin
  1642.   if NewStyleControls and (FBorderStyle = bsSingle) then RecreateWnd;
  1643.   inherited;
  1644. end;
  1645.  
  1646. { TForm }
  1647.  
  1648. constructor TForm.Create(AOwner: TComponent);
  1649. begin
  1650.   CreateNew(AOwner, 1);
  1651.   if ClassType <> TForm then
  1652.   begin
  1653.     Include(FFormState, fsCreating);
  1654.     try
  1655.       if not InitInheritedComponent(Self, TForm) then
  1656.         raise EResNotFound.CreateResFmt(SResNotFound, [ClassName]);
  1657.     finally
  1658.       Exclude(FFormState, fsCreating);
  1659.     end;
  1660.   end;
  1661. end;
  1662.  
  1663. constructor TForm.CreateNew(AOwner: TComponent; Dummy: Integer);
  1664. begin
  1665.   inherited Create(AOwner);
  1666.   ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
  1667.     csSetCaption, csDoubleClicks];
  1668.   Left := 0;
  1669.   Top := 0;
  1670.   Width := 320;
  1671.   Height := 240;
  1672.   Visible := False;
  1673.   ParentColor := False;
  1674.   ParentFont := False;
  1675.   Ctl3D := True;
  1676.   FBorderIcons := [biSystemMenu, biMinimize, biMaximize];
  1677.   FBorderStyle := bsSizeable;
  1678.   FWindowState := wsNormal;
  1679.   FIcon := TIcon.Create;
  1680.   FIcon.OnChange := IconChanged;
  1681.   FCanvas := TControlCanvas.Create;
  1682.   FCanvas.Control := Self;
  1683.   FPixelsPerInch := Screen.PixelsPerInch;
  1684.   FPrintScale := poProportional;
  1685.   Screen.AddForm(Self);
  1686. end;
  1687.  
  1688. destructor TForm.Destroy;
  1689. begin
  1690.   MergeMenu(False);
  1691.   if HandleAllocated then DestroyWindowHandle;
  1692.   Screen.RemoveForm(Self);
  1693.   FCanvas.Free;
  1694.   FIcon.Free;
  1695.   FMenu.Free;
  1696.   inherited Destroy;
  1697.   FOleFormObject.Free;
  1698. end;
  1699.  
  1700. procedure TForm.Notification(AComponent: TComponent;
  1701.   Operation: TOperation);
  1702. begin
  1703.   inherited Notification(AComponent, Operation);
  1704.   case Operation of
  1705.     opInsert:
  1706.       if not (csLoading in ComponentState) and (Menu = nil) and
  1707.         (AComponent.Owner = Self) and (AComponent is TMainMenu) then
  1708.         Menu := TMainMenu(AComponent);
  1709.     opRemove:
  1710.       begin
  1711.         if Menu = AComponent then Menu := nil;
  1712.         if WindowMenu = AComponent then WindowMenu := nil;
  1713.       end;
  1714.   end;
  1715.   if FDesigner <> nil then
  1716.     FDesigner.Notification(AComponent, Operation);
  1717. end;
  1718.  
  1719. procedure TForm.ReadState(Reader: TReader);
  1720. var
  1721.   NewTextHeight: Integer;
  1722.   Scaled: Boolean;
  1723. begin
  1724.   DisableAlign;
  1725.   try
  1726.     FClientWidth := 0;
  1727.     FClientHeight := 0;
  1728.     FTextHeight := 0;
  1729.     Scaled := False;
  1730.     inherited ReadState(Reader);
  1731.     if (FPixelsPerInch <> 0) and (FTextHeight > 0) then
  1732.     begin
  1733.       if (sfFont in ScalingFlags) and (FPixelsPerInch <> Screen.PixelsPerInch) then
  1734.         Font.Height := MulDiv(Font.Height, Screen.PixelsPerInch,
  1735.           FPixelsPerInch);
  1736.       FPixelsPerInch := Screen.PixelsPerInch;
  1737.       NewTextHeight := GetTextHeight;
  1738.       if FTextHeight <> NewTextHeight then
  1739.       begin
  1740.         Scaled := True;
  1741.         ScaleScrollBars(NewTextHeight, FTextHeight);
  1742.         ScaleControls(NewTextHeight, FTextHeight);
  1743.         if sfWidth in ScalingFlags then
  1744.           FClientWidth := MulDiv(FClientWidth, NewTextHeight, FTextHeight);
  1745.         if sfHeight in ScalingFlags then
  1746.           FClientHeight := MulDiv(FClientHeight, NewTextHeight, FTextHeight);
  1747.       end;
  1748.     end;
  1749.     if FClientWidth > 0 then inherited ClientWidth := FClientWidth;
  1750.     if FClientHeight > 0 then inherited ClientHeight := FClientHeight;
  1751.     ScalingFlags := [];
  1752.     if not Scaled then
  1753.     begin
  1754.       { Forces all ScalingFlags to [] }
  1755.       ScaleScrollBars(1, 1);
  1756.       ScaleControls(1, 1);
  1757.     end;
  1758.   finally
  1759.     EnableAlign;
  1760.   end;
  1761. end;
  1762.  
  1763. procedure TForm.DefineProperties(Filer: TFiler);
  1764. begin
  1765.   inherited DefineProperties(Filer);
  1766.   Filer.DefineProperty('PixelsPerInch', nil, WritePixelsPerInch,
  1767.     Filer is TWriter);
  1768.   Filer.DefineProperty('TextHeight', ReadTextHeight, WriteTextHeight, True);
  1769. end;
  1770.  
  1771. procedure TForm.ReadTextHeight(Reader: TReader);
  1772. begin
  1773.   FTextHeight := Reader.ReadInteger;
  1774. end;
  1775.  
  1776. procedure TForm.WriteTextHeight(Writer: TWriter);
  1777. begin
  1778.   Writer.WriteInteger(GetTextHeight);
  1779. end;
  1780.  
  1781. procedure TForm.WritePixelsPerInch(Writer: TWriter);
  1782. begin
  1783.   Writer.WriteInteger(GetPixelsPerInch);
  1784. end;
  1785.  
  1786. function TForm.GetTextHeight: Integer;
  1787. begin
  1788.   Result := Canvas.TextHeight('0');
  1789. end;
  1790.  
  1791. procedure TForm.ChangeScale(M, D: Integer);
  1792. var
  1793.   PriorHeight: Integer;
  1794. begin
  1795.   ScaleScrollBars(M, D);
  1796.   ScaleControls(M, D);
  1797.   if IsClientSizeStored then
  1798.   begin
  1799.     PriorHeight := ClientHeight;
  1800.     ClientWidth := MulDiv(ClientWidth, M, D);
  1801.     ClientHeight := MulDiv(PriorHeight, M, D);
  1802.   end;
  1803.   Font.Size := MulDiv(Font.Size, M, D);
  1804. end;
  1805.  
  1806. procedure TForm.IconChanged(Sender: TObject);
  1807. begin
  1808.   if NewStyleControls then
  1809.   begin
  1810.     if HandleAllocated and (BorderStyle <> bsDialog) then
  1811.       SendMessage(Handle, WM_SETICON, 1, GetIconHandle);
  1812.   end else
  1813.     if IsIconic(Handle) then Invalidate;
  1814. end;
  1815.  
  1816. function TForm.IsClientSizeStored: Boolean;
  1817. begin
  1818.   Result := not IsFormSizeStored;
  1819. end;
  1820.  
  1821. function TForm.IsFormSizeStored: Boolean;
  1822. begin
  1823.   Result := AutoScroll or (HorzScrollBar.Range <> 0) or
  1824.     (VertScrollBar.Range <> 0);
  1825. end;
  1826.  
  1827. function TForm.IsAutoScrollStored: Boolean;
  1828. begin
  1829.   Result := IsForm and
  1830.     (AutoScroll <> (BorderStyle in [bsSizeable, bsSizeToolWin]));
  1831. end;
  1832.  
  1833. procedure TForm.DoHide;
  1834. begin
  1835.   if Assigned(FOnHide) then FOnHide(Self);
  1836. end;
  1837.  
  1838. procedure TForm.DoShow;
  1839. begin
  1840.   if Assigned(FOnShow) then FOnShow(Self);
  1841. end;
  1842.  
  1843. function TForm.GetClientRect: TRect;
  1844. begin
  1845.   if IsIconic(Handle) then
  1846.   begin
  1847.     SetRect(Result, 0, 0, 0, 0);
  1848.     AdjustWindowRectEx(Result, GetWindowLong(Handle, GWL_STYLE),
  1849.       Menu <> nil, GetWindowLong(Handle, GWL_EXSTYLE));
  1850.     SetRect(Result, 0, 0,
  1851.       Width - Result.Right + Result.Left,
  1852.       Height - Result.Bottom + Result.Top);
  1853.   end else
  1854.     Result := inherited GetClientRect;
  1855. end;
  1856.  
  1857. procedure TForm.GetChildren(Proc: TGetChildProc);
  1858. var
  1859.   I: Integer;
  1860.   OwnedComponent: TComponent;
  1861. begin
  1862.   inherited GetChildren(Proc);
  1863.   for I := 0 to ComponentCount - 1 do
  1864.   begin
  1865.     OwnedComponent := Components[I];
  1866.     if not OwnedComponent.HasParent then Proc(OwnedComponent);
  1867.   end;
  1868. end;
  1869.  
  1870. procedure TForm.SetChildOrder(Child: TComponent; Order: Integer);
  1871. var
  1872.   I, J: Integer;
  1873. begin
  1874.   if Child is TControl then
  1875.     inherited SetChildOrder(Child, Order)
  1876.   else
  1877.   begin
  1878.     Dec(Order, ControlCount);
  1879.     J := -1;
  1880.     for I := 0 to ComponentCount - 1 do
  1881.       if not Components[I].HasParent then
  1882.       begin
  1883.         Inc(J);
  1884.         if J = Order then
  1885.         begin
  1886.           Child.ComponentIndex := I;
  1887.           Exit;
  1888.         end;
  1889.       end;
  1890.   end;
  1891. end;
  1892.  
  1893. procedure TForm.SetClientWidth(Value: Integer);
  1894. begin
  1895.   if csReadingState in ControlState then
  1896.   begin
  1897.     FClientWidth := Value;
  1898.     ScalingFlags := ScalingFlags + [sfWidth];
  1899.   end else inherited ClientWidth := Value;
  1900. end;
  1901.  
  1902. procedure TForm.SetClientHeight(Value: Integer);
  1903. begin
  1904.   if csReadingState in ControlState then
  1905.   begin
  1906.     FClientHeight := Value;
  1907.     ScalingFlags := ScalingFlags + [sfHeight];
  1908.   end else inherited ClientHeight := Value;
  1909. end;
  1910.  
  1911. procedure TForm.SetVisible(Value: Boolean);
  1912. begin
  1913.   if fsCreating in FFormState then
  1914.     if Value then
  1915.       Include(FFormState, fsVisible) else
  1916.       Exclude(FFormState, fsVisible)
  1917.   else
  1918.     inherited Visible := Value;
  1919. end;
  1920.  
  1921. procedure TForm.VisibleChanging;
  1922. begin
  1923.   if (FormStyle = fsMDIChild) and Visible then
  1924.     raise EInvalidOperation.CreateRes(SMDIChildNotVisible);
  1925. end;
  1926.  
  1927. procedure TForm.SetParent(AParent: TWinControl);
  1928. begin
  1929.   if (Parent <> AParent) and (AParent <> Self) then
  1930.   begin
  1931.     if Parent = nil then DestroyHandle;
  1932.     inherited SetParent(AParent);
  1933.     if Parent = nil then UpdateControlState;
  1934.   end;
  1935. end;
  1936.  
  1937. procedure TForm.ValidateRename(AComponent: TComponent;
  1938.   const CurName, NewName: string);
  1939. begin
  1940.   inherited ValidateRename(AComponent, CurName, NewName);
  1941.   if FDesigner <> nil then
  1942.     FDesigner.ValidateRename(AComponent, CurName, NewName);
  1943. end;
  1944.  
  1945. procedure TForm.WndProc(var Message: TMessage);
  1946. var
  1947.   FocusHandle: HWND;
  1948.   Rgn1, Rgn2: HRGN;
  1949.   BorderX, BorderY: Integer;
  1950. begin
  1951.   with Message do
  1952.     case Msg of
  1953.       WM_SETTEXT, WM_NCPAINT, WM_NCACTIVATE:
  1954.         if HandleAllocated and (FBorderStyle = bsDialog) and Ctl3D and
  1955.           Assigned(Ctl3DDlgFramePaint) then
  1956.         begin
  1957.           if Msg = WM_SETTEXT then
  1958.            { Work around Ctl3D unicode bug (garbage caption) and redraw flicker.
  1959.              The string must be given to the default proc, but the defaultproc
  1960.              also redraws the old-style border, causing lots of flicker.
  1961.              Use SetWindowRgn to prevent that redraw, then simulate a
  1962.              WM_NCPAINT for Ctl3DDlgFramePaint to draw the new caption. }
  1963.           begin
  1964.             Rgn1 := CreateRectRgn(0,0,Width,Height); // width & height required
  1965.             GetWindowRgn(Handle, Rgn1);
  1966.             SetWindowRgn(Handle, CreateRectRgn(0,0,0,0), False);
  1967.             inherited WndProc(Message);
  1968.             SetWindowRgn(Handle, Rgn1, False);  // takes ownership of region
  1969.             BorderX := GetSystemMetrics(SM_CXDLGFRAME);
  1970.             BorderY := GetSystemMetrics(SM_CYDLGFRAME);
  1971.             Rgn2 := CreateRectRgn(Left + BorderX + 2, Top + BorderY + 1,
  1972.               Left + Width - 2*BorderX,
  1973.               Top + BorderY + GetSystemMetrics(SM_CYCAPTION) - 1);
  1974.             Ctl3DDlgFramePaint(Handle, WM_NCPAINT, Rgn2, 0);
  1975.             DeleteObject(Rgn2);
  1976.           end
  1977.           else
  1978.             Result := Ctl3DDlgFramePaint(Handle, Msg, wParam, lParam);
  1979.           Exit;
  1980.         end;
  1981.       WM_ACTIVATE, WM_SETFOCUS, WM_KILLFOCUS:
  1982.         begin
  1983.           if not FocusMessages then Exit;
  1984.           if (Msg = WM_SETFOCUS) and not (csDesigning in ComponentState) then
  1985.           begin
  1986.             FocusHandle := 0;
  1987.             if FormStyle = fsMDIForm then
  1988.             begin
  1989.               if ActiveMDIChild <> nil then FocusHandle := ActiveMDIChild.Handle;
  1990.             end
  1991.             else if (FActiveControl <> nil) and (FActiveControl <> Self) then
  1992.               FocusHandle := FActiveControl.Handle;
  1993.             if FocusHandle <> 0 then
  1994.             begin
  1995.               Windows.SetFocus(FocusHandle);
  1996.               Exit;
  1997.             end;
  1998.           end;
  1999.         end;
  2000.       WM_WINDOWPOSCHANGING:
  2001.         if ([csLoading, csDesigning] * ComponentState = [csLoading]) then
  2002.         begin
  2003.           if (Position in [poDefault, poDefaultPosOnly]) and
  2004.             (WindowState <> wsMaximized) then
  2005.             with PWindowPos(Message.lParam)^ do flags := flags or SWP_NOMOVE;
  2006.           if Position in [poDefault, poDefaultSizeOnly] then
  2007.             with PWindowPos(Message.lParam)^ do flags := flags or SWP_NOSIZE;
  2008.         end;
  2009.     end;
  2010.   inherited WndProc(Message);
  2011. end;
  2012.  
  2013. procedure TForm.AfterConstruction;
  2014. begin
  2015.   if Assigned(FOnCreate) then
  2016.     try
  2017.       FOnCreate(Self);
  2018.     except
  2019.       Application.HandleException(Self);
  2020.     end;
  2021.     if fsVisible in FFormState then Visible := True;
  2022. end;
  2023.  
  2024. procedure TForm.BeforeDestruction;
  2025. begin
  2026.   Destroying;
  2027.   RemoveFixupReferences(Self, '');
  2028.   if FOleFormObject <> nil then FOleFormObject.OnDestroy;
  2029.   if FormStyle <> fsMDIChild then Hide;
  2030.   if Assigned(FOnDestroy) then
  2031.     try
  2032.       FOnDestroy(Self);
  2033.     except
  2034.       Application.HandleException(Self);
  2035.     end;
  2036. end;
  2037.  
  2038. procedure TForm.ClientWndProc(var Message: TMessage);
  2039.  
  2040.   procedure Default;
  2041.   begin
  2042.     with Message do
  2043.       Result := CallWindowProc(FDefClientProc, ClientHandle, Msg, wParam, lParam);
  2044.   end;
  2045.  
  2046. begin
  2047.   with Message do
  2048.     case Msg of
  2049.       WM_NCHITTEST:
  2050.         begin
  2051.           Default;
  2052.           if Result = HTCLIENT then Result := HTTRANSPARENT;
  2053.         end;
  2054.       WM_ERASEBKGND:
  2055.         begin
  2056.           FillRect(TWMEraseBkGnd(Message).DC, ClientRect, Brush.Handle);
  2057.           Result := 1;
  2058.         end;
  2059.     else
  2060.       Default;
  2061.     end;
  2062. end;
  2063.  
  2064. procedure TForm.AlignControls(AControl: TControl; var Rect: TRect);
  2065. begin
  2066.   inherited AlignControls(AControl, Rect);
  2067.   if ClientHandle <> 0 then
  2068.     with Rect do
  2069.       { NOCOPYBITS flag prevents paint problems in mdi client for ole toolbar
  2070.         negotiations, especially word/excel toolbar docking }
  2071.       SetWindowPos(FClientHandle, HWND_BOTTOM, Left, Top, Right - Left,
  2072.         Bottom - Top, SWP_NOCOPYBITS);
  2073. end;
  2074.  
  2075. procedure TForm.SetDesigner(ADesigner: TDesigner);
  2076. begin
  2077.   FDesigner := ADesigner;
  2078. end;
  2079.  
  2080. procedure TForm.SetBorderIcons(Value: TBorderIcons);
  2081. begin
  2082.   if FBorderIcons <> Value then
  2083.   begin
  2084.     FBorderIcons := Value;
  2085.     if not (csDesigning in ComponentState) then RecreateWnd;
  2086.   end;
  2087. end;
  2088.  
  2089. procedure TForm.SetBorderStyle(Value: TFormBorderStyle);
  2090. begin
  2091.   if FBorderStyle <> Value then
  2092.   begin
  2093.     FBorderStyle := Value;
  2094.     AutoScroll := FBorderStyle in [bsSizeable, bsSizeToolWin];
  2095.     if not (csDesigning in ComponentState) then RecreateWnd;
  2096.   end;
  2097. end;
  2098.  
  2099. function TForm.GetActiveMDIChild: TForm;
  2100. begin
  2101.   Result := nil;
  2102.   if (FormStyle = fsMDIForm) and (FClientHandle <> 0) then
  2103.     Result := TForm(FindControl(SendMessage(FClientHandle, WM_MDIGETACTIVE, 0,
  2104.       0)));
  2105. end;
  2106.  
  2107. function TForm.GetMDIChildCount: Integer;
  2108. var
  2109.   I: Integer;
  2110. begin
  2111.   Result := 0;
  2112.   if (FormStyle = fsMDIForm) and (FClientHandle <> 0) then
  2113.     for I := 0 to Screen.FormCount - 1 do
  2114.       if Screen.Forms[I].FormStyle = fsMDIChild then Inc(Result);
  2115. end;
  2116.  
  2117. function TForm.GetMDIChildren(I: Integer): TForm;
  2118. var
  2119.   J: Integer;
  2120. begin
  2121.   if (FormStyle = fsMDIForm) and (FClientHandle <> 0) then
  2122.     for J := 0 to Screen.FormCount - 1 do
  2123.     begin
  2124.       Result := Screen.Forms[J];
  2125.       if Result.FormStyle = fsMDIChild then
  2126.       begin
  2127.         Dec(I);
  2128.         if I < 0 then Exit;
  2129.       end;
  2130.     end;
  2131.   Result := nil;
  2132. end;
  2133.  
  2134. function TForm.GetCanvas: TCanvas;
  2135. begin
  2136.   Result := FCanvas;
  2137. end;
  2138.  
  2139. procedure TForm.SetIcon(Value: TIcon);
  2140. begin
  2141.   FIcon.Assign(Value);
  2142. end;
  2143.  
  2144. function TForm.IsColorStored: Boolean;
  2145. begin
  2146.   Result := (Ctl3D and (Color <> clBtnFace)) or (not Ctl3D and (Color <> clWindow));
  2147. end;
  2148.  
  2149. function TForm.IsForm: Boolean;
  2150. begin
  2151.   Result := not IsControl;
  2152. end;
  2153.  
  2154. function TForm.IsIconStored: Boolean;
  2155. begin
  2156.   Result := IsForm and (Icon.Handle <> 0);
  2157. end;
  2158.  
  2159. procedure TForm.SetFormStyle(Value: TFormStyle);
  2160. var
  2161.   OldStyle: TFormStyle;
  2162. begin
  2163.   if FFormStyle <> Value then
  2164.   begin
  2165.     if (Value = fsMDIChild) and (Position = poDesigned) then
  2166.       Position := poDefault;
  2167.     if not (csDesigning in ComponentState) then DestroyHandle;
  2168.     OldStyle := FFormStyle;
  2169.     FFormStyle := Value;
  2170.     if ((Value = fsMDIForm) or (OldStyle = fsMDIForm)) and not Ctl3d then
  2171.       Color := NormalColor;
  2172.     if not (csDesigning in ComponentState) then UpdateControlState;
  2173.     if Value = fsMDIChild then Visible := True;
  2174.   end;
  2175. end;
  2176.  
  2177. procedure TForm.RefreshMDIMenu;
  2178. var
  2179.   MenuHandle, WindowMenuHandle: HMenu;
  2180.   Redraw: Boolean;
  2181. begin
  2182.   if (FormStyle = fsMDIForm) and (ClientHandle <> 0) then
  2183.   begin
  2184.     MenuHandle := 0;
  2185.     if Menu <> nil then MenuHandle := Menu.Handle;
  2186.     WindowMenuHandle := 0;
  2187.     if WindowMenu <> nil then WindowMenuHandle := WindowMenu.Handle;
  2188.     Redraw := Windows.GetMenu(Handle) <> MenuHandle;
  2189.     SendMessage(ClientHandle, WM_MDISETMENU, MenuHandle, WindowMenuHandle);
  2190.     if Redraw then DrawMenuBar(Handle);
  2191.   end;
  2192. end;
  2193.  
  2194. procedure TForm.SetObjectMenuItem(Value: TMenuItem);
  2195. begin
  2196.   FObjectMenuItem := Value;
  2197.   if Value <> nil then Value.Enabled := False;
  2198. end;
  2199.  
  2200. procedure TForm.SetWindowMenu(Value: TMenuItem);
  2201. begin
  2202.   if FWindowMenu <> Value then
  2203.   begin
  2204.     FWindowMenu := Value;
  2205.     if Value <> nil then Value.FreeNotification(Self);
  2206.     RefreshMDIMenu;
  2207.   end;
  2208. end;
  2209.  
  2210. procedure TForm.SetMenu(Value: TMainMenu);
  2211. var
  2212.   I: Integer;
  2213. begin
  2214.   if Value <> nil then
  2215.     for I := 0 to Screen.FormCount - 1 do
  2216.       if (Screen.Forms[I].Menu = Value) and (Screen.Forms[I] <> Self) then
  2217.         raise EInvalidOperation.CreateResFmt(sDuplicateMenus, [Value.Name]);
  2218.   if FMenu <> nil then FMenu.WindowHandle := 0;
  2219.   FMenu := Value;
  2220.   if Value <> nil then Value.FreeNotification(Self);
  2221.   if (Value <> nil) and ((csDesigning in ComponentState) or
  2222.    (BorderStyle <> bsDialog)) then
  2223.   begin
  2224.     if not (Menu.AutoMerge or (FormStyle = fsMDIChild)) or
  2225.       (csDesigning in ComponentState) then
  2226.     begin
  2227.       if HandleAllocated then
  2228.       begin
  2229.         if Windows.GetMenu(Handle) <> Menu.Handle then
  2230.           Windows.SetMenu(Handle, Menu.Handle);
  2231.         Value.WindowHandle := Handle;
  2232.       end;
  2233.     end
  2234.     else if FormStyle <> fsMDIChild then
  2235.       if HandleAllocated then Windows.SetMenu(Handle, 0);
  2236.   end
  2237.   else if HandleAllocated then Windows.SetMenu(Handle, 0);
  2238.   if Active then MergeMenu(True);
  2239.   RefreshMDIMenu;
  2240. end;
  2241.  
  2242. function TForm.GetPixelsPerInch: Integer;
  2243. begin
  2244.   Result := FPixelsPerInch;
  2245.   if Result = 0 then Result := Screen.PixelsPerInch;
  2246. end;
  2247.  
  2248. procedure TForm.SetPixelsPerInch(Value: Integer);
  2249. begin
  2250.   if (Value <> GetPixelsPerInch) and ((Value = 0) or (Value >= 36))
  2251.     and (not (csLoading in ComponentState) or (FPixelsPerInch <> 0)) then
  2252.     FPixelsPerInch := Value;
  2253. end;
  2254.  
  2255. procedure TForm.SetPosition(Value: TPosition);
  2256. begin
  2257.   if FPosition <> Value then
  2258.   begin
  2259.     FPosition := Value;
  2260.     if not (csDesigning in ComponentState) then RecreateWnd;
  2261.   end;
  2262. end;
  2263.  
  2264. function TForm.GetScaled: Boolean;
  2265. begin
  2266.   Result := FPixelsPerInch <> 0;
  2267. end;
  2268.  
  2269. procedure TForm.SetScaled(Value: Boolean);
  2270. begin
  2271.   if Value <> GetScaled then
  2272.   begin
  2273.     FPixelsPerInch := 0;
  2274.     if Value then FPixelsPerInch := Screen.PixelsPerInch;
  2275.   end;
  2276. end;
  2277.  
  2278. procedure TForm.CMColorChanged(var Message: TMessage);
  2279. begin
  2280.   inherited;
  2281.   if FCanvas <> nil then FCanvas.Brush.Color := Color;
  2282. end;
  2283.  
  2284. function TForm.NormalColor: TColor;
  2285. begin
  2286.   Result := clWindow;
  2287.   if FormStyle = fsMDIForm then Result := clAppWorkSpace;
  2288. end;
  2289.  
  2290. procedure TForm.CMCtl3DChanged(var Message: TMessage);
  2291. begin
  2292.   inherited;
  2293.   if Ctl3D then
  2294.   begin
  2295.      if Color = NormalColor then Color := clBtnFace
  2296.   end
  2297.   else if Color = clBtnFace then Color := NormalColor;
  2298. end;
  2299.  
  2300. procedure TForm.CMFontChanged(var Message: TMessage);
  2301. begin
  2302.   inherited;
  2303.   if FCanvas <> nil then FCanvas.Font := Font;
  2304. end;
  2305.  
  2306. procedure TForm.CMMenuChanged(var Message: TMessage);
  2307. begin
  2308.   RefreshMDIMenu;
  2309.   SetMenu(FMenu);
  2310. end;
  2311.  
  2312. procedure TForm.SetWindowState(Value: TWindowState);
  2313. const
  2314.   ShowCommands: array[TWindowState] of Integer =
  2315.     (SW_SHOWNORMAL, SW_MINIMIZE, SW_SHOWMAXIMIZED);
  2316. begin
  2317.   if FWindowState <> Value then
  2318.   begin
  2319.     FWindowState := Value;
  2320.     if not (csDesigning in ComponentState) and Showing then
  2321.       ShowWindow(Handle, ShowCommands[Value]);
  2322.   end;
  2323. end;
  2324.  
  2325. procedure TForm.CreateParams(var Params: TCreateParams);
  2326. var
  2327.   Icons: TBorderIcons;
  2328.   CreateStyle: TFormBorderStyle;
  2329. begin
  2330.   inherited CreateParams(Params);
  2331.   with Params do
  2332.   begin
  2333.     if (Parent = nil) and (ParentWindow = 0) then
  2334.     begin
  2335.       WndParent := Application.Handle;
  2336.       Style := Style and not (WS_CHILD or WS_GROUP or WS_TABSTOP);
  2337.     end;
  2338.     WindowClass.style := CS_DBLCLKS;
  2339.     if csDesigning in ComponentState then
  2340.       Style := Style or (WS_CAPTION or WS_THICKFRAME or WS_MINIMIZEBOX or
  2341.         WS_MAXIMIZEBOX or WS_SYSMENU)
  2342.     else
  2343.     begin
  2344.       if FPosition in [poDefault, poDefaultPosOnly] then
  2345.       begin
  2346.         X := CW_USEDEFAULT;
  2347.         Y := CW_USEDEFAULT;
  2348.       end;
  2349.       Icons := FBorderIcons;
  2350.       CreateStyle := FBorderStyle;
  2351.       if (FormStyle = fsMDIChild) and (CreateStyle in [bsNone, bsDialog]) then
  2352.         CreateStyle := bsSizeable;
  2353.       case CreateStyle of
  2354.         bsNone:
  2355.           begin
  2356.             if (Parent = nil) and (ParentWindow = 0) then
  2357.               Style := Style or WS_POPUP;
  2358.             Icons := [];
  2359.           end;
  2360.         bsSingle, bsToolWindow:
  2361.           Style := Style or (WS_CAPTION or WS_BORDER);
  2362.         bsSizeable, bsSizeToolWin:
  2363.           begin
  2364.             Style := Style or (WS_CAPTION or WS_THICKFRAME);
  2365.             if FPosition in [poDefault, poDefaultSizeOnly] then
  2366.             begin
  2367.               Width := CW_USEDEFAULT;
  2368.               Height := CW_USEDEFAULT;
  2369.             end;
  2370.           end;
  2371.         bsDialog:
  2372.           begin
  2373.             Style := Style or WS_POPUP or WS_CAPTION;
  2374.             ExStyle := WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE;
  2375.             if not NewStyleControls then
  2376.               Style := Style or WS_DLGFRAME or DS_MODALFRAME;
  2377.             Icons := Icons * [biSystemMenu, biHelp];
  2378.             WindowClass.style := CS_DBLCLKS or CS_SAVEBITS or
  2379.               CS_BYTEALIGNWINDOW;
  2380.           end;
  2381.       end;
  2382.       if CreateStyle in [bsToolWindow, bsSizeToolWin] then
  2383.       begin
  2384.         ExStyle := WS_EX_TOOLWINDOW;
  2385.         Icons := Icons * [biSystemMenu];
  2386.       end;
  2387.       if CreateStyle in [bsSingle, bsSizeable] then
  2388.       begin
  2389.         if (FormStyle <> fsMDIChild) or (biSystemMenu in Icons) then
  2390.         begin
  2391.           if biMinimize in Icons then Style := Style or WS_MINIMIZEBOX;
  2392.           if biMaximize in Icons then Style := Style or WS_MAXIMIZEBOX;
  2393.         end;
  2394.         if FWindowState = wsMinimized then Style := Style or WS_MINIMIZE else
  2395.           if FWindowState = wsMaximized then Style := Style or WS_MAXIMIZE;
  2396.       end else FWindowState := wsNormal;
  2397.       if biSystemMenu in Icons then Style := Style or WS_SYSMENU;
  2398.       if (biHelp in Icons) then ExStyle := ExStyle or WS_EX_CONTEXTHELP;
  2399.       if FormStyle = fsMDIChild then WindowClass.lpfnWndProc := @DefMDIChildProc;
  2400.     end;
  2401.   end;
  2402. end;
  2403.  
  2404. procedure TForm.CreateWnd;
  2405. var
  2406.   ClientCreateStruct: TClientCreateStruct;
  2407. begin
  2408.   inherited CreateWnd;
  2409.   if NewStyleControls then
  2410.     if BorderStyle <> bsDialog then
  2411.       SendMessage(Handle, WM_SETICON, 1, GetIconHandle) else
  2412.       SendMessage(Handle, WM_SETICON, 1, 0);
  2413.   if not (csDesigning in ComponentState) then
  2414.     case FormStyle of
  2415.       fsMDIForm:
  2416.         begin
  2417.           with ClientCreateStruct do
  2418.           begin
  2419.             idFirstChild := $FF00;
  2420.             hWindowMenu := 0;
  2421.             if FWindowMenu <> nil then hWindowMenu := FWindowMenu.Handle;
  2422.           end;
  2423.           FClientHandle := Windows.CreateWindow('MDICLIENT', nil,
  2424.             WS_CHILD or WS_VISIBLE or WS_GROUP or WS_TABSTOP or
  2425.             WS_CLIPCHILDREN or WS_HSCROLL or WS_VSCROLL or
  2426.             WS_CLIPSIBLINGS or MDIS_ALLCHILDSTYLES,
  2427.             0, 0, ClientWidth, ClientHeight, Handle, 0, HInstance,
  2428.             @ClientCreateStruct);
  2429.           FClientInstance := MakeObjectInstance(ClientWndProc);
  2430.           FDefClientProc := Pointer(GetWindowLong(FClientHandle, GWL_WNDPROC));
  2431.           SetWindowLong(FClientHandle, GWL_WNDPROC, Longint(FClientInstance));
  2432.         end;
  2433.       fsStayOnTop:
  2434.         SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
  2435.           SWP_NOSIZE or SWP_NOACTIVATE);
  2436.     end;
  2437. end;
  2438.  
  2439. procedure TForm.CreateWindowHandle(const Params: TCreateParams);
  2440. var
  2441.   CreateStruct: TMDICreateStruct;
  2442. begin
  2443.   if (FormStyle = fsMDIChild) and not (csDesigning in ComponentState) then
  2444.   begin
  2445.     if (Application.MainForm = nil) or
  2446.       (Application.MainForm.ClientHandle = 0) then
  2447.       raise EInvalidOperation.CreateRes(SNoMDIForm);
  2448.     with CreateStruct do
  2449.     begin
  2450.       szClass := Params.WinClassName;
  2451.       szTitle := Params.Caption;
  2452.       hOwner := HInstance;
  2453.       X := Params.X;
  2454.       Y := Params.Y;
  2455.       cX := Params.Width;
  2456.       cY := Params.Height;
  2457.       style := Params.Style;
  2458.       lParam := Longint(Params.Param);
  2459.     end;
  2460.     WindowHandle := SendMessage(Application.MainForm.ClientHandle,
  2461.       WM_MDICREATE, 0, Longint(@CreateStruct));
  2462.     Include(FFormState, fsCreatedMDIChild);
  2463.   end else
  2464.   begin
  2465.     inherited CreateWindowHandle(Params);
  2466.     Exclude(FFormState, fsCreatedMDIChild);
  2467.   end;
  2468. end;
  2469.  
  2470. procedure TForm.DestroyWindowHandle;
  2471. begin
  2472.   if fsCreatedMDIChild in FFormState then
  2473.     SendMessage(Application.MainForm.ClientHandle, WM_MDIDESTROY, Handle, 0)
  2474.   else
  2475.     inherited DestroyWindowHandle;
  2476.   FClientHandle := 0;
  2477. end;
  2478.  
  2479. procedure TForm.DefaultHandler(var Message);
  2480. begin
  2481.   if ClientHandle <> 0 then
  2482.     with TMessage(Message) do
  2483.       if Msg = WM_SIZE then
  2484.         Result := DefWindowProc(Handle, Msg, wParam, lParam) else
  2485.         Result := DefFrameProc(Handle, ClientHandle, Msg, wParam, lParam)
  2486.   else
  2487.     inherited DefaultHandler(Message)
  2488. end;
  2489.  
  2490. procedure TForm.SetActiveControl(Control: TWinControl);
  2491. begin
  2492.   if FActiveControl <> Control then
  2493.   begin
  2494.     if not ((Control = nil) or (Control <> Self) and
  2495.       (GetParentForm(Control) = Self) and Control.CanFocus) then
  2496.       raise EInvalidOperation.CreateRes(SCannotFocus);
  2497.     FActiveControl := Control;
  2498.     if FActive then SetWindowFocus;
  2499.     ActiveChanged;
  2500.   end;
  2501. end;
  2502.  
  2503. procedure TForm.DefocusControl(Control: TWinControl; Removing: Boolean);
  2504. begin
  2505.   if Removing and Control.ContainsControl(FFocusedControl) then
  2506.     FFocusedControl := Control.Parent;
  2507.   if Control.ContainsControl(FActiveControl) then SetActiveControl(nil);
  2508. end;
  2509.  
  2510. procedure TForm.FocusControl(Control: TWinControl);
  2511. var
  2512.   WasActive: Boolean;
  2513. begin
  2514.   WasActive := FActive;
  2515.   SetActiveControl(Control);
  2516.   if not WasActive then SetFocus;
  2517. end;
  2518.  
  2519. function TForm.SetFocusedControl(Control: TWinControl): Boolean;
  2520. var
  2521.   FocusHandle: HWnd;
  2522.   TempControl: TWinControl;
  2523. begin
  2524.   Result := False;
  2525.   Inc(FocusCount);
  2526.   if FDesigner = nil then
  2527.     if Control <> Self then
  2528.       FActiveControl := Control else
  2529.       FActiveControl := nil;
  2530.   Screen.FActiveControl := Control;
  2531.   Screen.FActiveForm := Self;
  2532.   Screen.FForms.Remove(Self);
  2533.   Screen.FForms.Insert(0, Self);
  2534.   if not (csFocusing in Control.ControlState) then
  2535.   begin
  2536.     Control.ControlState := Control.ControlState + [csFocusing];
  2537.     try
  2538.       if Screen.FFocusedForm <> Self then
  2539.       begin
  2540.         if Screen.FFocusedForm <> nil then
  2541.         begin
  2542.           FocusHandle := Screen.FFocusedForm.Handle;
  2543.           Screen.FFocusedForm := nil;
  2544.           if not SendFocusMessage(FocusHandle, CM_DEACTIVATE) then Exit;
  2545.         end;
  2546.         Screen.FFocusedForm := Self;
  2547.         if not SendFocusMessage(Handle, CM_ACTIVATE) then Exit;
  2548.       end;
  2549.       if FFocusedControl = nil then FFocusedControl := Self;
  2550.       if FFocusedControl <> Control then
  2551.       begin
  2552.         while not FFocusedControl.ContainsControl(Control) do
  2553.         begin
  2554.           FocusHandle := FFocusedControl.Handle;
  2555.           FFocusedControl := FFocusedControl.Parent;
  2556.           if not SendFocusMessage(FocusHandle, CM_EXIT) then Exit;
  2557.         end;
  2558.         while FFocusedControl <> Control do
  2559.         begin
  2560.           TempControl := Control;
  2561.           while TempControl.Parent <> FFocusedControl do
  2562.             TempControl := TempControl.Parent;
  2563.           FFocusedControl := TempControl;
  2564.           if not SendFocusMessage(TempControl.Handle, CM_ENTER) then Exit;
  2565.         end;
  2566.         TempControl := Control.Parent;
  2567.         while TempControl <> nil do
  2568.         begin
  2569.           if TempControl is TScrollingWinControl then
  2570.             TScrollingWinControl(TempControl).AutoScrollInView(Control);
  2571.           TempControl := TempControl.Parent;
  2572.         end;
  2573.         Perform(CM_FOCUSCHANGED, 0, Longint(Control));
  2574.         if (FActiveOleControl <> nil) and (FActiveOleControl <> Control) then
  2575.           FActiveOleControl.Perform(CM_UIDEACTIVATE, 0, 0);
  2576.       end;
  2577.     finally
  2578.       Control.ControlState := Control.ControlState - [csFocusing];
  2579.     end;
  2580.     Screen.UpdateLastActive;
  2581.     Result := True;
  2582.   end;
  2583. end;
  2584.  
  2585. procedure TForm.ActiveChanged;
  2586. begin
  2587. end;
  2588.  
  2589. procedure TForm.SetWindowFocus;
  2590. var
  2591.   FocusControl: TWinControl;
  2592. begin
  2593.   if (FActiveControl <> nil) and (FDesigner = nil) then
  2594.     FocusControl := FActiveControl else
  2595.     FocusControl := Self;
  2596.   Windows.SetFocus(FocusControl.Handle);
  2597.   if GetFocus = FocusControl.Handle then
  2598.     FocusControl.Perform(CM_UIACTIVATE, 0, 0);
  2599. end;
  2600.  
  2601. procedure TForm.SetActive(Value: Boolean);
  2602. begin
  2603.   FActive := Value;
  2604.   if FActiveOleControl <> nil then
  2605.     FActiveOleControl.Perform(CM_DOCWINDOWACTIVATE, Ord(Value), 0);
  2606.   if Value then
  2607.   begin
  2608.     if (ActiveControl = nil) and not (csDesigning in ComponentState) then
  2609.       ActiveControl := FindNextControl(nil, True, True, False);
  2610.     MergeMenu(True);
  2611.     SetWindowFocus;
  2612.   end;
  2613. end;
  2614.  
  2615. procedure TForm.SendCancelMode(Sender: TControl);
  2616. begin
  2617.   if Active and (ActiveControl <> nil) then
  2618.     ActiveControl.Perform(CM_CANCELMODE, 0, Longint(Sender));
  2619.   if (FormStyle = fsMDIForm) and (ActiveMDIChild <> nil) then
  2620.     ActiveMDIChild.SendCancelMode(Sender);
  2621. end;
  2622.  
  2623. procedure TForm.MergeMenu(MergeState: Boolean);
  2624. var
  2625.   AMergeMenu: TMainMenu;
  2626.   Size: Longint;
  2627. begin
  2628.   if not (fsModal in FFormState) and
  2629.     (Application.MainForm <> nil) and
  2630.     (Application.MainForm.Menu <> nil) and
  2631.     (Application.MainForm <> Self) and
  2632.     ((FormStyle = fsMDIChild) or (Application.MainForm.FormStyle <> fsMDIForm)) then
  2633.   begin
  2634.     AMergeMenu := nil;
  2635.     if not (csDesigning in ComponentState) and (Menu <> nil) and
  2636.       (Menu.AutoMerge or (FormStyle = fsMDIChild)) then AMergeMenu := Menu;
  2637.     with Application.MainForm.Menu do
  2638.       if MergeState then Merge(AMergeMenu) else Unmerge(AMergeMenu);
  2639.     if MergeState and (FormStyle = fsMDIChild) and (WindowState = wsMaximized) then
  2640.     begin
  2641.       { Force MDI to put back the system menu of a maximized child }
  2642.       Size := ClientWidth + (Longint(ClientHeight) shl 16);
  2643.       SendMessage(Handle, WM_SIZE, SIZE_RESTORED, Size);
  2644.       SendMessage(Handle, WM_SIZE, SIZE_MAXIMIZED, Size);
  2645.     end;
  2646.   end;
  2647. end;
  2648.  
  2649. procedure TForm.Activate;
  2650. begin
  2651.   if Assigned(FOnActivate) then FOnActivate(Self);
  2652. end;
  2653.  
  2654. procedure TForm.Deactivate;
  2655. begin
  2656.   if Assigned(FOnDeactivate) then FOnDeactivate(Self);
  2657. end;
  2658.  
  2659. procedure TForm.Paint;
  2660. begin
  2661.   if Assigned(FOnPaint) then FOnPaint(Self);
  2662. end;
  2663.  
  2664. procedure TForm.Resize;
  2665. begin
  2666.   if Assigned(FOnResize) then FOnResize(Self);
  2667. end;
  2668.  
  2669. function TForm.GetIconHandle: HICON;
  2670. begin
  2671.   Result := FIcon.Handle;
  2672.   if Result = 0 then Result := Application.GetIconHandle;
  2673. end;
  2674.  
  2675. procedure TForm.PaintWindow(DC: HDC);
  2676. begin
  2677.   FCanvas.Handle := DC;
  2678.   try
  2679.     if FDesigner <> nil then FDesigner.PaintGrid else Paint;
  2680.   finally
  2681.     FCanvas.Handle := 0;
  2682.   end;
  2683. end;
  2684.  
  2685. function TForm.PaletteChanged(Foreground: Boolean): Boolean;
  2686. var
  2687.   I: Integer;
  2688.   Active, Child: TForm;
  2689. begin
  2690.   Result := False;
  2691.   Child := nil;
  2692.   Active := ActiveMDIChild;
  2693.   if Assigned(Active) then
  2694.     Result := Active.PaletteChanged(Foreground);
  2695.   for I := 0 to MDIChildCount-1 do
  2696.   begin
  2697.     if Foreground and Result then Exit;
  2698.     Child := MDIChildren[I];
  2699.     if Active = Child then Continue;
  2700.     Result := Child.PaletteChanged(Foreground) or Result;
  2701.   end;
  2702.   if Foreground and Result then Exit;
  2703.   Result := inherited PaletteChanged(Foreground);
  2704. end;
  2705.  
  2706. procedure TForm.WMPaint(var Message: TWMPaint);
  2707. var
  2708.   DC: HDC;
  2709.   PS: TPaintStruct;
  2710. begin
  2711.   if not IsIconic(Handle) then PaintHandler(Message) else
  2712.   begin
  2713.     DC := BeginPaint(Handle, PS);
  2714.     DrawIcon(DC, 0, 0, GetIconHandle);
  2715.     EndPaint(Handle, PS);
  2716.   end;
  2717. end;
  2718.  
  2719. procedure TForm.WMIconEraseBkgnd(var Message: TWMIconEraseBkgnd);
  2720. begin
  2721.   if FormStyle = fsMDIChild then
  2722.   if (FormStyle = fsMDIChild) and not (csDesigning in ComponentState) then
  2723.     FillRect(Message.DC, ClientRect, Application.MainForm.Brush.Handle)
  2724.   else inherited;
  2725. end;
  2726.  
  2727. procedure TForm.WMEraseBkgnd(var Message: TWMEraseBkgnd);
  2728. begin
  2729.   if not IsIconic(Handle) then inherited else
  2730.   begin
  2731.     Message.Msg := WM_ICONERASEBKGND;
  2732.     DefaultHandler(Message);
  2733.   end;
  2734. end;
  2735.  
  2736. procedure TForm.WMQueryDragIcon(var Message: TWMQueryDragIcon);
  2737. begin
  2738.   Message.Result := GetIconHandle;
  2739. end;
  2740.  
  2741. procedure TForm.WMNCCreate(var Message: TWMNCCreate);
  2742.  
  2743.   procedure ModifySystemMenu;
  2744.   var
  2745.     SysMenu: HMENU;
  2746.   begin
  2747.     if (FBorderStyle <> bsNone) and (biSystemMenu in FBorderIcons) and
  2748.       (FormStyle <> fsMDIChild) then
  2749.     begin
  2750.       { Modify the system menu to look more like it's s'pose to }
  2751.       SysMenu := GetSystemMenu(Handle, False);
  2752.       if FBorderStyle = bsDialog then
  2753.       begin
  2754.         { Make the system menu look like a dialog which has only
  2755.           Move and Close }
  2756.         DeleteMenu(SysMenu, SC_TASKLIST, MF_BYCOMMAND);
  2757.         DeleteMenu(SysMenu, 7, MF_BYPOSITION);
  2758.         DeleteMenu(SysMenu, 5, MF_BYPOSITION);
  2759.         DeleteMenu(SysMenu, SC_MAXIMIZE, MF_BYCOMMAND);
  2760.         DeleteMenu(SysMenu, SC_MINIMIZE, MF_BYCOMMAND);
  2761.         DeleteMenu(SysMenu, SC_SIZE, MF_BYCOMMAND);
  2762.         DeleteMenu(SysMenu, SC_RESTORE, MF_BYCOMMAND);
  2763.       end else
  2764.       begin
  2765.         { Else just disable the Minimize and Maximize items if the
  2766.           corresponding FBorderIcon is not present }
  2767.         if not (biMinimize in FBorderIcons) then
  2768.           EnableMenuItem(SysMenu, SC_MINIMIZE, MF_BYCOMMAND or MF_GRAYED);
  2769.         if not (biMaximize in FBorderIcons) then
  2770.           EnableMenuItem(SysMenu, SC_MAXIMIZE, MF_BYCOMMAND or MF_GRAYED);
  2771.       end;
  2772.     end;
  2773.   end;
  2774.  
  2775. begin
  2776.   inherited;
  2777.   SetMenu(FMenu);
  2778.   if not (csDesigning in ComponentState) then ModifySystemMenu;
  2779. end;
  2780.  
  2781. procedure TForm.WMDestroy(var Message: TWMDestroy);
  2782. begin
  2783.   if NewStyleControls then SendMessage(Handle, WM_SETICON, 1, 0);
  2784.   if (FMenu <> nil) and (FormStyle <> fsMDIChild) then
  2785.   begin
  2786.     Windows.SetMenu(Handle, 0);
  2787.     FMenu.WindowHandle := 0;
  2788.   end;
  2789.   inherited;
  2790. end;
  2791.  
  2792. procedure TForm.WMCommand(var Message: TWMCommand);
  2793. begin
  2794.   with Message do
  2795.     if (Ctl <> 0) or (Menu = nil) or not Menu.DispatchCommand(ItemID) then
  2796.       inherited;
  2797. end;
  2798.  
  2799. procedure TForm.WMInitMenuPopup(var Message: TWMInitMenuPopup);
  2800. begin
  2801.   if FMenu <> nil then FMenu.DispatchPopup(Message.MenuPopup);
  2802. end;
  2803.  
  2804. procedure TForm.WMMenuSelect(var Message: TWMMenuSelect);
  2805. var
  2806.   MenuItem: TMenuItem;
  2807.   ID: Integer;
  2808.   FindKind: TFindItemKind;
  2809. begin
  2810.   if FMenu <> nil then
  2811.     with Message do
  2812.     begin
  2813.       MenuItem := nil;
  2814.       if (MenuFlag <> $FFFF) or (IDItem <> 0) then
  2815.       begin
  2816.         FindKind := fkCommand;
  2817.         ID := IDItem;
  2818.         if MenuFlag and MF_POPUP <> 0 then
  2819.         begin
  2820.           FindKind := fkHandle;
  2821.           ID := GetSubMenu(Menu, ID);
  2822.         end;
  2823.         MenuItem := FMenu.FindItem(ID, FindKind);
  2824.       end;
  2825.       if MenuItem <> nil then
  2826.         Application.Hint := GetLongHint(MenuItem.Hint) else
  2827.         Application.Hint := '';
  2828.     end;
  2829. end;
  2830.  
  2831. procedure TForm.WMActivate(var Message: TWMActivate);
  2832. begin
  2833.   if (FormStyle <> fsMDIForm) or (csDesigning in ComponentState) then
  2834.     SetActive(Message.Active <> WA_INACTIVE);
  2835. end;
  2836.  
  2837. procedure TForm.WMSize(var Message: TWMSize);
  2838. begin
  2839.   inherited;
  2840.   if not (csDesigning in ComponentState) then
  2841.     case Message.SizeType of
  2842.       SIZENORMAL: FWindowState := wsNormal;
  2843.       SIZEICONIC: FWindowState := wsMinimized;
  2844.       SIZEFULLSCREEN: FWindowState := wsMaximized;
  2845.     end;
  2846.   if FOleFormObject <> nil then FOleFormObject.OnResize;
  2847.   if not (csLoading in ComponentState) then Resize;
  2848.   CalcAutoRange;
  2849. end;
  2850.  
  2851. procedure TForm.WMClose(var Message: TWMClose);
  2852. begin
  2853.   Close;
  2854. end;
  2855.  
  2856. procedure TForm.WMQueryEndSession(var Message: TWMQueryEndSession);
  2857. begin
  2858.   Message.Result := Longint(CloseQuery);
  2859. end;
  2860.  
  2861. procedure TForm.CMAppSysCommand(var Message: TMessage);
  2862. type
  2863.   PWMSysCommand = ^TWMSysCommand;
  2864. begin
  2865.   Message.Result := 0;
  2866.   if (csDesigning in ComponentState) or (FormStyle = fsMDIChild) or
  2867.    (Menu = nil) or Menu.AutoMerge then
  2868.     with PWMSysCommand(Message.lParam)^ do
  2869.     begin
  2870.       SendCancelMode(nil);
  2871.       if SendAppMessage(CM_APPSYSCOMMAND, CmdType, Key) <> 0 then
  2872.         Message.Result := 1;;
  2873.     end;
  2874. end;
  2875.  
  2876. procedure TForm.WMSysCommand(var Message: TWMSysCommand);
  2877. begin
  2878.   if (Message.CmdType and $FFF0 = SC_MINIMIZE) and
  2879.     (Application.MainForm = Self) then
  2880.     Application.Minimize
  2881.   else
  2882.     inherited;
  2883. end;
  2884.  
  2885. procedure TForm.WMShowWindow(var Message: TWMShowWindow);
  2886. const
  2887.   ShowCommands: array[saRestore..saMaximize] of Integer =
  2888.     (SW_SHOWNOACTIVATE, SW_SHOWMINNOACTIVE, SW_SHOWMAXIMIZED);
  2889. begin
  2890.   with Message do
  2891.     case Status of
  2892.       SW_PARENTCLOSING:
  2893.         begin
  2894.           if IsIconic(Handle) then FShowAction := saMinimize else
  2895.             if IsZoomed(Handle) then FShowAction := saMaximize else
  2896.               FShowAction := saRestore;
  2897.           inherited;
  2898.         end;
  2899.       SW_PARENTOPENING:
  2900.         if FShowAction <> saIgnore then
  2901.         begin
  2902.           ShowWindow(Handle, ShowCommands[FShowAction]);
  2903.           FShowAction := saIgnore;
  2904.         end;
  2905.     else
  2906.       inherited;
  2907.     end;
  2908. end;
  2909.  
  2910. procedure TForm.WMMDIActivate(var Message: TWMMDIActivate);
  2911. var
  2912.   IsActive: Boolean;
  2913. begin
  2914.   inherited;
  2915.   if FormStyle = fsMDIChild then
  2916.   begin
  2917.     IsActive := Message.ActiveWnd = Handle;
  2918.     SetActive(IsActive);
  2919.     if IsActive and (csPalette in Application.MainForm.ControlState) then
  2920.       Application.MainForm.PaletteChanged(True);
  2921.   end;
  2922. end;
  2923.  
  2924. procedure TForm.WMNextDlgCtl(var Message: TWMNextDlgCtl);
  2925. begin
  2926.   with Message do
  2927.     if Handle then
  2928.       Windows.SetFocus(Message.CtlFocus) else
  2929.       SelectNext(FActiveControl, not BOOL(CtlFocus), True);
  2930. end;
  2931.  
  2932. procedure TForm.WMEnterMenuLoop(var Message: TMessage);
  2933. begin
  2934.   SendCancelMode(nil);
  2935.   inherited;
  2936. end;
  2937.  
  2938. procedure TForm.WMHelp(var Message: TWMHelp);
  2939.  
  2940.   function GetMenuHelpContext(Menu: TMenu): Integer;
  2941.   begin
  2942.     Result := 0;
  2943.     if Menu = nil then Exit;
  2944.     Result := Menu.GetHelpContext(Message.HelpInfo.iCtrlID, True);
  2945.     if Result = 0 then
  2946.       Result := Menu.GetHelpContext(Message.HelpInfo.hItemHandle, False);
  2947.   end;
  2948.  
  2949. var
  2950.   Control: TWinControl;
  2951.   ContextID: Integer;
  2952. begin
  2953.   with Message.HelpInfo^ do
  2954.   begin
  2955.     if Message.HelpInfo.iContextType = HELPINFO_WINDOW then
  2956.     begin
  2957.       Control := FindControl(hItemHandle);
  2958.       while (Control <> nil) and (Control.HelpContext = 0) do
  2959.         Control := Control.Parent;
  2960.       if Control = nil then Exit;
  2961.       ContextID := Control.HelpContext;
  2962.     end
  2963.     else  { Message.HelpInfo.iContextType = HELPINFO_MENUITEM }
  2964.     begin
  2965.       ContextID := GetMenuHelpContext(FMenu);
  2966.       if ContextID = 0 then
  2967.         ContextID := GetMenuHelpContext(PopupMenu);
  2968.     end;
  2969.   end;
  2970.   if (biHelp in BorderIcons) then
  2971.     Application.HelpCommand(HELP_CONTEXTPOPUP, ContextID)
  2972.   else
  2973.     Application.HelpContext(ContextID);
  2974. end;
  2975.  
  2976. procedure TForm.CMActivate(var Message: TCMActivate);
  2977. begin
  2978.   Activate;
  2979. end;
  2980.  
  2981. procedure TForm.CMDeactivate(var Message: TCMDeactivate);
  2982. begin
  2983.   Deactivate;
  2984. end;
  2985.  
  2986. procedure TForm.CMDialogKey(var Message: TCMDialogKey);
  2987. begin
  2988.   if GetKeyState(VK_MENU) >= 0 then
  2989.     with Message do
  2990.       case CharCode of
  2991.         VK_TAB:
  2992.           if GetKeyState(VK_CONTROL) >= 0 then
  2993.           begin
  2994.             SelectNext(FActiveControl, GetKeyState(VK_SHIFT) >= 0, True);
  2995.             Result := 1;
  2996.             Exit;
  2997.           end;
  2998.         VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN:
  2999.           begin
  3000.             if FActiveControl <> nil then
  3001.             begin
  3002.               TForm(FActiveControl.Parent).SelectNext(FActiveControl,
  3003.                 (CharCode = VK_RIGHT) or (CharCode = VK_DOWN), False);
  3004.               Result := 1;
  3005.             end;
  3006.             Exit;
  3007.           end;
  3008.       end;
  3009.   inherited;
  3010. end;
  3011.  
  3012. procedure TForm.CMShowingChanged(var Message: TMessage);
  3013. const
  3014.   ShowCommands: array[TWindowState] of Integer =
  3015.     (SW_SHOWNORMAL, SW_SHOWMINNOACTIVE, SW_SHOWMAXIMIZED);
  3016. var
  3017.   X, Y: Integer;
  3018.   NewActiveWindow: HWnd;
  3019. begin
  3020.   if not (csDesigning in ComponentState) and (fsShowing in FFormState) then
  3021.     raise EInvalidOperation.CreateRes(SVisibleChanged);
  3022.   Include(FFormState, fsShowing);
  3023.   try
  3024.     if not (csDesigning in ComponentState) then
  3025.       if Showing then
  3026.       begin
  3027.         try
  3028.           DoShow;
  3029.         except
  3030.           Application.HandleException(Self);
  3031.         end;
  3032.         if FPosition = poScreenCenter then
  3033.         begin
  3034.           if FormStyle = fsMDIChild then
  3035.           begin
  3036.             X := (Application.MainForm.ClientWidth - Width) div 2;
  3037.             Y := (Application.MainForm.ClientHeight - Height) div 2;
  3038.           end else
  3039.           begin
  3040.             X := (Screen.Width - Width) div 2;
  3041.             Y := (Screen.Height - Height) div 2;
  3042.           end;
  3043.           if X < 0 then X := 0;
  3044.           if Y < 0 then Y := 0;
  3045.           SetBounds(X, Y, Width, Height);
  3046.         end;
  3047.         FPosition := poDesigned;
  3048.         if FormStyle = fsMDIChild then
  3049.         begin
  3050.           { Fake a size message to get MDI to behave }
  3051.           if FWindowState = wsMaximized then
  3052.           begin
  3053.             SendMessage(Application.MainForm.ClientHandle, WM_MDIRESTORE, Handle, 0);
  3054.             ShowWindow(Handle, SW_SHOWMAXIMIZED);
  3055.           end
  3056.           else
  3057.           begin
  3058.             ShowWindow(Handle, ShowCommands[FWindowState]);
  3059.             CallWindowProc(@DefMDIChildProc, Handle, WM_SIZE, SIZE_RESTORED,
  3060.               Width or (Height shl 16));
  3061.             BringToFront;
  3062.           end;
  3063.           SendMessage(Application.MainForm.ClientHandle,
  3064.             WM_MDIREFRESHMENU, 0, 0);
  3065.         end
  3066.         else
  3067.           ShowWindow(Handle, ShowCommands[FWindowState]);
  3068.       end else
  3069.       begin
  3070.         try
  3071.           DoHide;
  3072.         except
  3073.           Application.HandleException(Self);
  3074.         end;
  3075.         if Screen.ActiveForm = Self then
  3076.           MergeMenu(False);
  3077.         if FormStyle = fsMDIChild then
  3078.           DestroyHandle
  3079.         else if fsModal in FFormState then
  3080.           SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_HIDEWINDOW or
  3081.             SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE)
  3082.         else
  3083.         begin
  3084.           NewActiveWindow := 0;
  3085.           if (GetActiveWindow = Handle) and not IsIconic(Handle) then
  3086.             NewActiveWindow := FindTopMostWindow(Handle);
  3087.           if NewActiveWindow <> 0 then
  3088.           begin
  3089.             SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_HIDEWINDOW or
  3090.               SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE);
  3091.             SetActiveWindow(NewActiveWindow);
  3092.           end else
  3093.             ShowWindow(Handle, SW_HIDE);
  3094.         end;
  3095.       end;
  3096.   finally
  3097.     Exclude(FFormState, fsShowing);
  3098.   end;
  3099. end;
  3100.  
  3101. procedure TForm.CMIconChanged(var Message: TMessage);
  3102. begin
  3103.   if FIcon.Handle = 0 then IconChanged(nil);
  3104. end;
  3105.  
  3106. procedure TForm.CMRelease;
  3107. begin
  3108.   Free;
  3109. end;
  3110.  
  3111. procedure TForm.CMTextChanged(var Message: TMessage);
  3112. begin
  3113.   inherited;
  3114.   if (FormStyle = fsMDIChild) and (Application.MainForm <> nil) and
  3115.     (Application.MainForm.ClientHandle <> 0) then
  3116.     SendMessage(Application.MainForm.ClientHandle, WM_MDIREFRESHMENU, 0, 0);
  3117. end;
  3118.  
  3119. procedure TForm.CMUIActivate(var Message);
  3120. begin
  3121.   inherited;
  3122. end;
  3123.  
  3124. procedure TForm.Close;
  3125. var
  3126.   CloseAction: TCloseAction;
  3127. begin
  3128.   if fsModal in FFormState then
  3129.     ModalResult := mrCancel
  3130.   else
  3131.     if CloseQuery then
  3132.     begin
  3133.       if FormStyle = fsMDIChild then
  3134.         if biMinimize in BorderIcons then
  3135.           CloseAction := caMinimize else
  3136.           CloseAction := caNone
  3137.       else
  3138.         CloseAction := caHide;
  3139.       if Assigned(FOnClose) then FOnClose(Self, CloseAction);
  3140.       if CloseAction <> caNone then
  3141.         if Application.MainForm = Self then Application.Terminate
  3142.         else if CloseAction = caHide then Hide
  3143.         else if CloseAction = caMinimize then WindowState := wsMinimized
  3144.         else Release;
  3145.     end;
  3146. end;
  3147.  
  3148. function TForm.CloseQuery: Boolean;
  3149. var
  3150.   I: Integer;
  3151. begin
  3152.   if FormStyle = fsMDIForm then
  3153.   begin
  3154.     Result := False;
  3155.     for I := 0 to MDIChildCount - 1 do
  3156.       if not MDIChildren[I].CloseQuery then Exit;
  3157.   end;
  3158.   Result := True;
  3159.   if Assigned(FOnCloseQuery) then FOnCloseQuery(Self, Result);
  3160. end;
  3161.  
  3162. procedure TForm.CloseModal;
  3163. var
  3164.   CloseAction: TCloseAction;
  3165. begin
  3166.   try
  3167.     CloseAction := caNone;
  3168.     if CloseQuery then
  3169.     begin
  3170.       CloseAction := caHide;
  3171.       if Assigned(FOnClose) then FOnClose(Self, CloseAction);
  3172.     end;
  3173.     case CloseAction of
  3174.       caNone: ModalResult := 0;
  3175.       caFree: Release;
  3176.     end;
  3177.   except
  3178.     ModalResult := 0;
  3179.     Application.HandleException(Self);
  3180.   end;
  3181. end;
  3182.  
  3183. function TForm.GetFormImage: TBitmap;
  3184. var
  3185.   ScreenDC, PrintDC: HDC;
  3186.   OldBits, PrintBits: HBITMAP;
  3187.   PaintLParam: Longint;
  3188.  
  3189.   procedure PrintHandle(Handle: HWND);
  3190.   var
  3191.     R: TRect;
  3192.     Child: HWND;
  3193.     SavedIndex: Integer;
  3194.   begin
  3195.     if IsWindowVisible(Handle) then
  3196.     begin
  3197.       SavedIndex := SaveDC(PrintDC);
  3198.       Windows.GetClientRect(Handle, R);
  3199.       MapWindowPoints(Handle, Self.Handle, R, 2);
  3200.       with R do
  3201.       begin
  3202.         SetWindowOrgEx(PrintDC, -Left, -Top, nil);
  3203.         IntersectClipRect(PrintDC, 0, 0, Right - Left, Bottom - Top);
  3204.       end;
  3205.       SendMessage(Handle, WM_ERASEBKGND, PrintDC, 0);
  3206.       SendMessage(Handle, WM_PAINT, PrintDC, PaintLParam);
  3207.       Child := GetWindow(Handle, GW_CHILD);
  3208.       if Child <> 0 then
  3209.       begin
  3210.         Child := GetWindow(Child, GW_HWNDLAST);
  3211.         while Child <> 0 do
  3212.         begin
  3213.           PrintHandle(Child);
  3214.           Child := GetWindow(Child, GW_HWNDPREV);
  3215.         end;
  3216.       end;
  3217.       RestoreDC(PrintDC, SavedIndex);
  3218.     end;
  3219.   end;
  3220.  
  3221. begin
  3222.   Result := nil;
  3223.   ScreenDC := GetDC(0);
  3224.   PaintLParam := 0;
  3225.   try
  3226.     PrintDC := CreateCompatibleDC(ScreenDC);
  3227.     try
  3228.       PrintBits := CreateCompatibleBitmap(ScreenDC, ClientWidth, ClientHeight);
  3229.       try
  3230.         OldBits := SelectObject(PrintDC, PrintBits);
  3231.         try
  3232.           { Clear the contents of the bitmap }
  3233.           FillRect(PrintDC, ClientRect, Brush.Handle);
  3234.  
  3235.           { Paint form into a bitmap }
  3236.           PrintHandle(Handle);
  3237.         finally
  3238.           SelectObject(PrintDC, OldBits);
  3239.         end;
  3240.         Result := TBitmap.Create;
  3241.         Result.Handle := PrintBits;
  3242.         PrintBits := 0;
  3243.       except
  3244.         Result.Free;
  3245.         if PrintBits <> 0 then DeleteObject(PrintBits);
  3246.         raise;
  3247.       end;
  3248.     finally
  3249.       DeleteDC(PrintDC);
  3250.     end;
  3251.   finally
  3252.     ReleaseDC(0, ScreenDC);
  3253.   end;
  3254. end;
  3255.  
  3256. procedure TForm.Print;
  3257. var
  3258.   FormImage: TBitmap;
  3259.   Info: PBitmapInfo;
  3260.   InfoSize: Integer;
  3261.   Image: Pointer;
  3262.   ImageSize: DWORD;
  3263.   Bits: HBITMAP;
  3264.   DIBWidth, DIBHeight: Longint;
  3265.   PrintWidth, PrintHeight: Longint;
  3266. begin
  3267.   Printer.BeginDoc;
  3268.   try
  3269.     FormImage := GetFormImage;
  3270.     try
  3271.       { Paint bitmap to the printer }
  3272.       with Printer, Canvas do
  3273.       begin
  3274.         Bits := FormImage.Handle;
  3275.         GetDIBSizes(Bits, InfoSize, ImageSize);
  3276.         Info := AllocMem(InfoSize);
  3277.         try
  3278.           Image := AllocMem(ImageSize);
  3279.           try
  3280.             GetDIB(Bits, 0, Info^, Image^);
  3281.             with Info^.bmiHeader do
  3282.             begin
  3283.               DIBWidth := biWidth;
  3284.               DIBHeight := biHeight;
  3285.             end;
  3286.             case PrintScale of
  3287.               poProportional:
  3288.                 begin
  3289.                   PrintWidth := MulDiv(DIBWidth, GetDeviceCaps(Handle,
  3290.                     LOGPIXELSX), PixelsPerInch);
  3291.                   PrintHeight := MulDiv(DIBHeight, GetDeviceCaps(Handle,
  3292.                     LOGPIXELSY), PixelsPerInch);
  3293.                 end;
  3294.               poPrintToFit:
  3295.                 begin
  3296.                   PrintWidth := MulDiv(DIBWidth, PageHeight, DIBHeight);
  3297.                   if PrintWidth < PageWidth then
  3298.                     PrintHeight := PageHeight
  3299.                   else
  3300.                   begin
  3301.                     PrintWidth := PageWidth;
  3302.                     PrintHeight := MulDiv(DIBHeight, PageWidth, DIBWidth);
  3303.                   end;
  3304.                 end;
  3305.             else
  3306.               PrintWidth := DIBWidth;
  3307.               PrintHeight := DIBHeight;
  3308.             end;
  3309.             StretchDIBits(Canvas.Handle, 0, 0, PrintWidth, PrintHeight, 0, 0,
  3310.               DIBWidth, DIBHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY);
  3311.           finally
  3312.             FreeMem(Image, ImageSize);
  3313.           end;
  3314.         finally
  3315.           FreeMem(Info, InfoSize);
  3316.         end;
  3317.       end;
  3318.     finally
  3319.       FormImage.Free;
  3320.     end;
  3321.   finally
  3322.     Printer.EndDoc;
  3323.   end;
  3324. end;
  3325.  
  3326. procedure TForm.Hide;
  3327. begin
  3328.   Visible := False;
  3329. end;
  3330.  
  3331. procedure TForm.Show;
  3332. begin
  3333.   Visible := True;
  3334.   BringToFront;
  3335. end;
  3336.  
  3337. procedure TForm.SetFocus;
  3338. begin
  3339.   if not FActive then
  3340.   begin
  3341.     if not (Visible and Enabled) then
  3342.       raise EInvalidOperation.CreateRes(SCannotFocus);
  3343.     SetWindowFocus;
  3344.   end;
  3345. end;
  3346.  
  3347. function TForm.ShowModal: Integer;
  3348. var
  3349.   WindowList: Pointer;
  3350.   SaveFocusCount: Integer;
  3351.   SaveFocusedForm: TForm;
  3352.   SaveCursor: TCursor;
  3353.   ActiveWindow: HWnd;
  3354. begin
  3355.   CancelDrag;
  3356.   if Visible or not Enabled or (fsModal in FFormState) or
  3357.     (FormStyle = fsMDIChild) then
  3358.     raise EInvalidOperation.CreateRes(SCannotShowModal);
  3359.   if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
  3360.   ReleaseCapture;
  3361.   Include(FFormState, fsModal);
  3362.   ActiveWindow := GetActiveWindow;
  3363.   SaveFocusCount := FocusCount;
  3364.   SaveFocusedForm := Screen.FFocusedForm;
  3365.   Screen.RestoreFocusForms.Add(SaveFocusedForm);
  3366.   Screen.FFocusedForm := Self;
  3367.   SaveCursor := Screen.Cursor;
  3368.   Screen.Cursor := crDefault;
  3369.   WindowList := DisableTaskWindows(0);
  3370.   try
  3371.     Show;
  3372.     try
  3373.       SendMessage(Handle, CM_ACTIVATE, 0, 0);
  3374.       ModalResult := 0;
  3375.       repeat
  3376.         Application.HandleMessage;
  3377.         if Application.FTerminate then ModalResult := mrCancel else
  3378.           if ModalResult <> 0 then CloseModal;
  3379.       until ModalResult <> 0;
  3380.       Result := ModalResult;
  3381.       SendMessage(Handle, CM_DEACTIVATE, 0, 0);
  3382.       if GetActiveWindow <> Handle then ActiveWindow := 0;
  3383.     finally
  3384.       Hide;
  3385.     end;
  3386.   finally
  3387.     Screen.Cursor := SaveCursor;
  3388.     EnableTaskWindows(WindowList);
  3389.     if Screen.RestoreFocusForms.Remove(SaveFocusedForm) <> -1 then
  3390.       Screen.FFocusedForm := SaveFocusedForm
  3391.     else
  3392.       Screen.FFocusedForm := nil;
  3393.     if ActiveWindow <> 0 then SetActiveWindow(ActiveWindow);
  3394.     FocusCount := SaveFocusCount;
  3395.     Exclude(FFormState, fsModal);
  3396.   end;
  3397. end;
  3398.  
  3399. procedure TForm.Tile;
  3400. const
  3401.   TileParams: array[TTileMode] of Word = (MDITILE_HORIZONTAL, MDITILE_VERTICAL);
  3402. begin
  3403.   if (FFormStyle = fsMDIForm) and (ClientHandle <> 0) then
  3404.     SendMessage(ClientHandle, WM_MDITILE, TileParams[FTileMode], 0);
  3405. end;
  3406.  
  3407. procedure TForm.Cascade;
  3408. begin
  3409.   if (FFormStyle = fsMDIForm) and (ClientHandle <> 0) then
  3410.     SendMessage(ClientHandle, WM_MDICASCADE, 0, 0);
  3411. end;
  3412.  
  3413. procedure TForm.ArrangeIcons;
  3414. begin
  3415.   if (FFormStyle = fsMDIForm) and (ClientHandle <> 0) then
  3416.     SendMessage(ClientHandle, WM_MDIICONARRANGE, 0, 0);
  3417. end;
  3418.  
  3419. procedure TForm.Next;
  3420. begin
  3421.   if (FFormStyle = fsMDIForm) and (ClientHandle <> 0) then
  3422.     SendMessage(ClientHandle, WM_MDINEXT, 0, 0);
  3423. end;
  3424.  
  3425. procedure TForm.Previous;
  3426. begin
  3427.   if (FormStyle = fsMDIForm) and (ClientHandle <> 0) then
  3428.     SendMessage(FClientHandle, WM_MDINEXT, 0, 1);
  3429. end;
  3430.  
  3431. procedure TForm.Release;
  3432. begin
  3433.   PostMessage(Handle, CM_RELEASE, 0, 0);
  3434. end;
  3435.  
  3436. { TDataModule }
  3437.  
  3438. constructor TDataModule.Create(AOwner: TComponent);
  3439. begin
  3440.   CreateNew(AOwner, 1);
  3441.   if ClassType <> TDataModule then
  3442.   begin
  3443.     if not InitInheritedComponent(Self, TDataModule) then
  3444.       raise EResNotFound.CreateResFmt(SResNotFound, [ClassName]);
  3445.   end;
  3446. end;
  3447.  
  3448. constructor TDataModule.CreateNew(AOwner: TComponent; Dummy: Integer);
  3449. begin
  3450.   inherited Create(AOwner);
  3451.   Screen.AddDataModule(Self);
  3452. end;
  3453.  
  3454. destructor TDataModule.Destroy;
  3455. begin
  3456.   Screen.RemoveDataModule(Self);
  3457.   inherited Destroy;
  3458. end;
  3459.  
  3460. procedure TDataModule.DefineProperties(Filer: TFiler);
  3461. var
  3462.   Ancestor: TDataModule;
  3463.  
  3464.   function DoWriteWidth: Boolean;
  3465.   begin
  3466.     Result := True;
  3467.     if Ancestor <> nil then Result := FDesignSize.X <> Ancestor.FDesignSize.X;
  3468.   end;
  3469.  
  3470.   function DoWriteHorizontalOffset: Boolean;
  3471.   begin
  3472.     if Ancestor <> nil then
  3473.       Result := FDesignOffset.X <> Ancestor.FDesignOffset.X else
  3474.       Result := FDesignOffset.X <> 0;
  3475.   end;
  3476.  
  3477.   function DoWriteVerticalOffset: Boolean;
  3478.   begin
  3479.     if Ancestor <> nil then
  3480.       Result := FDesignOffset.Y <> Ancestor.FDesignOffset.Y else
  3481.       Result := FDesignOffset.Y <> 0;
  3482.   end;
  3483.  
  3484.   function DoWriteHeight: Boolean;
  3485.   begin
  3486.     Result := True;
  3487.     if Ancestor <> nil then Result := FDesignSize.Y <> Ancestor.FDesignSize.Y;
  3488.   end;
  3489.  
  3490. begin
  3491.   inherited DefineProperties(Filer);
  3492.   Ancestor := TDataModule(Filer.Ancestor);
  3493.   Filer.DefineProperty('Height', ReadHeight, WriteHeight, DoWriteHeight);
  3494.   Filer.DefineProperty('HorizontalOffset', ReadHorizontalOffset,
  3495.     WriteHorizontalOffset, DoWriteHorizontalOffset);
  3496.   Filer.DefineProperty('VerticalOffset', ReadVerticalOffset,
  3497.     WriteVerticalOffset, DoWriteVerticalOffset);
  3498.   Filer.DefineProperty('Width', ReadWidth, WriteWidth, DoWriteWidth);
  3499. end;
  3500.  
  3501. procedure TDataModule.GetChildren(Proc: TGetChildProc);
  3502. var
  3503.   I: Integer;
  3504.   OwnedComponent: TComponent;
  3505. begin
  3506.   inherited GetChildren(Proc);
  3507.   for I := 0 to ComponentCount - 1 do
  3508.   begin
  3509.     OwnedComponent := Components[I];
  3510.     if not OwnedComponent.HasParent then Proc(OwnedComponent);
  3511.   end;
  3512. end;
  3513.  
  3514. procedure TDataModule.AfterConstruction;
  3515. begin
  3516.   if Assigned(FOnCreate) then
  3517.     try
  3518.       FOnCreate(Self);
  3519.     except
  3520.       Application.HandleException(Self);
  3521.     end;
  3522. end;
  3523.  
  3524. procedure TDataModule.BeforeDestruction;
  3525. begin
  3526.   Destroying;
  3527.   RemoveFixupReferences(Self, '');
  3528.   if Assigned(FOnDestroy) then
  3529.     try
  3530.       FOnDestroy(Self);
  3531.     except
  3532.       Application.HandleException(Self);
  3533.     end;
  3534. end;
  3535.  
  3536. procedure TDataModule.ReadWidth(Reader: TReader);
  3537. begin
  3538.   FDesignSize.X := Reader.ReadInteger;
  3539. end;
  3540.  
  3541. procedure TDataModule.ReadHorizontalOffset(Reader: TReader);
  3542. begin
  3543.   FDesignOffset.X := Reader.ReadInteger;
  3544. end;
  3545.  
  3546. procedure TDataModule.ReadVerticalOffset(Reader: TReader);
  3547. begin
  3548.   FDesignOffset.Y := Reader.ReadInteger;
  3549. end;
  3550.  
  3551. procedure TDataModule.ReadHeight(Reader: TReader);
  3552. begin
  3553.   FDesignSize.Y := Reader.ReadInteger;
  3554. end;
  3555.  
  3556. procedure TDataModule.WriteWidth(Writer: TWriter);
  3557. begin
  3558.   Writer.WriteInteger(FDesignSize.X);
  3559. end;
  3560.  
  3561. procedure TDataModule.WriteHorizontalOffset(Writer: TWriter);
  3562. begin
  3563.   Writer.WriteInteger(FDesignOffset.X);
  3564. end;
  3565.  
  3566. procedure TDataModule.WriteVerticalOffset(Writer: TWriter);
  3567. begin
  3568.   Writer.WriteInteger(FDesignOffset.Y);
  3569. end;
  3570.  
  3571. procedure TDataModule.WriteHeight(Writer: TWriter);
  3572. begin
  3573.   Writer.WriteInteger(FDesignSize.Y);
  3574. end;
  3575.  
  3576. { TScreen }
  3577.  
  3578. const
  3579.   IDC_NODROP =    PChar(32767);
  3580.   IDC_DRAG   =    PChar(32766);
  3581.   IDC_HSPLIT =    PChar(32765);
  3582.   IDC_VSPLIT =    PChar(32764);
  3583.   IDC_MULTIDRAG = PChar(32763);
  3584.   IDC_SQLWAIT =   PChar(32762);
  3585.  
  3586. function EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
  3587.   FontType: Integer; Data: Pointer): Integer; stdcall;
  3588. begin
  3589.   TStrings(Data).Add(LogFont.lfFaceName);
  3590.   Result := 1;
  3591. end;
  3592.  
  3593. constructor TScreen.Create(AOwner: TComponent);
  3594. var
  3595.   DC: HDC;
  3596.   LFont: TLogFont;
  3597. begin
  3598.   inherited Create(AOwner);
  3599.   CreateCursors;
  3600.   InitImes;
  3601.   FFonts := TStringList.Create;
  3602.   FForms := TList.Create;
  3603.   FDataModules := TList.Create;
  3604.   DC := GetDC(0);
  3605.   TStringList(FFonts).Sorted := TRUE;
  3606.   TStringList(FFonts).Duplicates := dupIgnore;
  3607.  
  3608.   if Lo(GetVersion) >= 4 then
  3609.   begin
  3610.     LFont.lfCharset := DEFAULT_CHARSET;
  3611.     LFont.lfFaceName[0] := #0;
  3612.     EnumFontFamiliesEx(DC, LFont, @EnumFontsProc, LongInt(FFonts), 0);
  3613.   end
  3614.   else
  3615.     EnumFonts(DC, nil, @EnumFontsProc, Pointer(FFonts));
  3616.   FRestoreFocusForms := TList.Create;
  3617.   FPixelsPerInch := GetDeviceCaps(DC, LOGPIXELSY);
  3618.   ReleaseDC(0, DC);
  3619. end;
  3620.  
  3621. destructor TScreen.Destroy;
  3622. begin
  3623.   FDataModules.Free;
  3624.   FForms.Free;
  3625.   FFonts.Free;
  3626.   FImes.Free;
  3627.   FRestoreFocusForms.Free;
  3628.   DestroyCursors;
  3629.   inherited Destroy;
  3630. end;
  3631.  
  3632. function TScreen.GetHeight: Integer;
  3633. begin
  3634.   Result := GetSystemMetrics(SM_CYSCREEN);
  3635. end;
  3636.  
  3637. function TScreen.GetWidth: Integer;
  3638. begin
  3639.   Result := GetSystemMetrics(SM_CXSCREEN);
  3640. end;
  3641.  
  3642. function TScreen.GetForm(Index: Integer): TForm;
  3643. begin
  3644.   Result := FForms[Index];
  3645. end;
  3646.  
  3647. function TScreen.GetFormCount: Integer;
  3648. begin
  3649.   Result := FForms.Count;
  3650. end;
  3651.  
  3652. procedure TScreen.UpdateLastActive;
  3653. begin
  3654.   if FLastActiveForm <> FActiveForm then
  3655.   begin
  3656.     FLastActiveForm := FActiveForm;
  3657.     if Assigned(FOnActiveFormChange) then FOnActiveFormChange(Self);
  3658.   end;
  3659.   if FLastActiveControl <> FActiveControl then
  3660.   begin
  3661.     FLastActiveControl := FActiveControl;
  3662.     if Assigned(FOnActiveControlChange) then FOnActiveControlChange(Self);
  3663.   end;
  3664. end;
  3665.  
  3666. procedure TScreen.AddForm(AForm: TForm);
  3667. begin
  3668.   FForms.Add(AForm);
  3669. end;
  3670.  
  3671. procedure TScreen.RemoveForm(AForm: TForm);
  3672. begin
  3673.   FForms.Remove(AForm);
  3674.   if (FForms.Count = 0) and (Application.FHintWindow <> nil) then
  3675.     Application.FHintWindow.ReleaseHandle;
  3676. end;
  3677.  
  3678. procedure TScreen.AddDataModule(DataModule: TDataModule);
  3679. begin
  3680.   FDataModules.Add(DataModule);
  3681. end;
  3682.  
  3683. procedure TScreen.RemoveDataModule(DataModule: TDataModule);
  3684. begin
  3685.   FDataModules.Remove(DataModule);
  3686. end;
  3687.  
  3688. procedure TScreen.CreateCursors;
  3689. const
  3690.   CursorMap: array[crHelp..crArrow] of PChar = (
  3691.     IDC_HELP, IDC_APPSTARTING, IDC_NO, IDC_SQLWAIT, IDC_MULTIDRAG, IDC_VSPLIT,
  3692.     IDC_HSPLIT, IDC_NODROP, IDC_DRAG, IDC_WAIT, IDC_UPARROW, IDC_SIZEWE,
  3693.     IDC_SIZENWSE, IDC_SIZENS, IDC_SIZENESW, IDC_ARROW, IDC_IBEAM, IDC_CROSS,
  3694.     IDC_ARROW);
  3695. var
  3696.   I: Integer;
  3697.   Instance: THandle;
  3698. begin
  3699.   FDefaultCursor := LoadCursor(0, IDC_ARROW);
  3700.   for I := Low(CursorMap) to High(CursorMap) do
  3701.   begin
  3702.     if (I >= crSqlWait) and (I <= crDrag) then
  3703.       Instance := HInstance else
  3704.       Instance := 0;
  3705.     InsertCursor(I, LoadCursor(Instance, CursorMap[I]));
  3706.   end;
  3707. end;
  3708.  
  3709. procedure TScreen.DestroyCursors;
  3710. var
  3711.   P, Next: PCursorRec;
  3712.   Hdl: THandle;
  3713. begin
  3714.   P := FCursorList;
  3715.   while P <> nil do
  3716.   begin
  3717.     if (P^.Index <= crDrag) or (P^.Index > 0) then
  3718.       DestroyCursor(P^.Handle);
  3719.     Next := P^.Next;
  3720.     Dispose(P);
  3721.     P := Next;
  3722.   end;
  3723.   Hdl := LoadCursor(0, IDC_ARROW);
  3724.   if Hdl <> FDefaultCursor then
  3725.     DestroyCursor(FDefaultCursor);
  3726. end;
  3727.  
  3728. procedure TScreen.DeleteCursor(Index: Integer);
  3729. var
  3730.   P, Q: PCursorRec;
  3731. begin
  3732.   P := FCursorList;
  3733.   Q := nil;
  3734.   while (P <> nil) and (P^.Index <> Index) do
  3735.   begin
  3736.     Q := P;
  3737.     P := P^.Next;
  3738.   end;
  3739.   if P <> nil then
  3740.   begin
  3741.     DestroyCursor(P^.Handle);
  3742.     if Q = nil then FCursorList := P^.Next else Q^.Next := P^.Next;
  3743.     Dispose(P);
  3744.   end;
  3745. end;
  3746.  
  3747. procedure TScreen.InsertCursor(Index: Integer; Handle: HCURSOR);
  3748. var
  3749.   P: PCursorRec;
  3750. begin
  3751.   New(P);
  3752.   P^.Next := FCursorList;
  3753.   P^.Index := Index;
  3754.   P^.Handle := Handle;
  3755.   FCursorList := P;
  3756. end;
  3757.  
  3758. procedure TScreen.InitImes;
  3759. const
  3760.   KbLayoutRegkeyFmt = 'System\CurrentControlSet\Control\Keyboard Layouts\%.8x';  // do not localize
  3761.   KbLayoutRegSubkey = 'layout text'; // do not localize
  3762. var
  3763.   TotalKbLayout, I, Bufsize: Integer;
  3764.   KbList: array[0..63] of HKL;
  3765.   qKey: HKey;
  3766.   ImeFileName: array [Byte] of Char;
  3767.   RegKey: array [0..63] of Char;
  3768. begin
  3769.   FImes := TStringList.Create;
  3770.  
  3771.   FDefaultIme := '';
  3772.   FDefaultKbLayout := GetKeyboardLayout(0);
  3773.   TotalKbLayout := GetKeyboardLayoutList(64, KbList);
  3774.  
  3775.   for I := 0 to TotalKbLayout - 1 do
  3776.   begin
  3777.     if Imm32IsIME(KbList[I]) then
  3778.     begin
  3779.       if RegOpenKeyEx(HKEY_LOCAL_MACHINE,
  3780.         StrFmt(RegKey, KbLayoutRegKeyFmt, [KbList[I]]), 0, KEY_ALL_ACCESS,
  3781.         qKey) = ERROR_SUCCESS then
  3782.       try
  3783.         Bufsize := sizeof(ImeFileName);
  3784.         if RegQueryValueEx(qKey, KbLayoutRegSubKey, nil, nil,
  3785.              @ImeFileName, @Bufsize) = ERROR_SUCCESS then
  3786.         begin
  3787.           FImes.AddObject(ImeFileName, TObject(KbList[I]));
  3788.           if KbList[I] = FDefaultKbLayout then
  3789.             FDefaultIme := ImeFileName;
  3790.         end;
  3791.       finally
  3792.         RegCloseKey(qKey);
  3793.       end;
  3794.     end;
  3795.   end;
  3796.   TStringList(FImes).Duplicates := dupIgnore;
  3797.   TStringList(FImes).Sorted := TRUE;
  3798. end;
  3799.  
  3800. function TScreen.GetDataModule(Index: Integer): TDataModule;
  3801. begin
  3802.   Result := FDataModules[Index];
  3803. end;
  3804.  
  3805. function TScreen.GetDataModuleCount: Integer;
  3806. begin
  3807.   Result := FDataModules.Count;
  3808. end;
  3809.  
  3810. function TScreen.GetCursors(Index: Integer): HCURSOR;
  3811. var
  3812.   P: PCursorRec;
  3813. begin
  3814.   Result := 0;
  3815.   if Index <> crNone then
  3816.   begin
  3817.     P := FCursorList;
  3818.     while (P <> nil) and (P^.Index <> Index) do P := P^.Next;
  3819.     if P = nil then Result := FDefaultCursor else Result := P^.Handle;
  3820.   end;
  3821. end;
  3822.  
  3823. procedure TScreen.SetCursor(Value: TCursor);
  3824. var
  3825.   P: TPoint;
  3826.   Handle: HWND;
  3827.   Code: Longint;
  3828. begin
  3829.   if Value <> Cursor then
  3830.   begin
  3831.     FCursor := Value;
  3832.     if Value = crDefault then
  3833.     begin
  3834.       { Reset the cursor to the default by sending a WM_SETCURSOR to the
  3835.         window under the cursor }
  3836.       GetCursorPos(P);
  3837.       Handle := WindowFromPoint(P);
  3838.       if (Handle <> 0) and
  3839.         (GetWindowThreadProcessId(Handle, nil) = GetCurrentThreadId) then
  3840.       begin
  3841.         Code := SendMessage(Handle, WM_NCHITTEST, P.X, P.Y);
  3842.         SendMessage(Handle, WM_SETCURSOR, Handle, MakeLong(Code, WM_MOUSEMOVE));
  3843.         Exit;
  3844.       end;
  3845.     end;
  3846.     Windows.SetCursor(Cursors[Value]);
  3847.   end;
  3848. end;
  3849.  
  3850. procedure TScreen.SetCursors(Index: Integer; Handle: HCURSOR);
  3851. begin
  3852.   if Index = crDefault then
  3853.     if Handle = 0 then
  3854.       FDefaultCursor := LoadCursor(0, IDC_ARROW)
  3855.     else
  3856.       FDefaultCursor := Handle
  3857.   else if Index <> crNone then
  3858.   begin
  3859.     DeleteCursor(Index);
  3860.     if Handle <> 0 then InsertCursor(Index, Handle);
  3861.   end;
  3862. end;
  3863.  
  3864. { Hint functions }
  3865.  
  3866. function GetHint(Control: TControl): string;
  3867. begin
  3868.   while Control <> nil do
  3869.     if Control.Hint = '' then
  3870.       Control := Control.Parent
  3871.     else
  3872.     begin
  3873.       Result := Control.Hint;
  3874.       Exit;
  3875.     end;
  3876.   Result := '';
  3877. end;
  3878.  
  3879. function GetHintControl(Control: TControl): TControl;
  3880. begin
  3881.   Result := Control;
  3882.   while (Result <> nil) and not Result.ShowHint do Result := Result.Parent;
  3883.   if (Result <> nil) and (csDesigning in Result.ComponentState) then Result := nil;
  3884. end;
  3885.  
  3886. procedure HintTimerProc(Wnd: HWnd; Msg, TimerID, SysTime: Longint); stdcall;
  3887. begin
  3888.   if Application <> nil then Application.HintTimerExpired;
  3889. end;
  3890.  
  3891. { DLL specific hint routines - Only executed in the context of a DLL to
  3892.   simulate hooks the .EXE has in the message loop }
  3893.  
  3894. procedure HintMouseThread(Param: Integer); stdcall;
  3895. var
  3896.   P: TPoint;
  3897. begin
  3898.   while True do
  3899.   begin
  3900.     WaitForInputIdle(GetCurrentProcess, 1000);
  3901.     if (Application <> nil) and (Application.FHintControl <> nil) then
  3902.     begin
  3903.       GetCursorPos(P);
  3904.       if FindVCLWindow(P) = nil then Application.CancelHint;
  3905.     end;
  3906.   end;
  3907. end;
  3908.  
  3909. var
  3910.   HintHook: HHOOK;
  3911.   HintThread: THandle;
  3912.  
  3913. function HintGetMsgHook(nCode: Integer; wParam: Longint; var Msg: TMsg): Longint; stdcall;
  3914. const
  3915.   FakeMoveMessage: TWMMouse = (
  3916.     Msg: WM_MOUSEMOVE);
  3917. begin
  3918.   Result := CallNextHookEx(HintHook, nCode, wParam, Longint(@Msg));
  3919.   if (nCode >= 0) and (Application <> nil) then Application.IsHintMsg(Msg);
  3920. end;
  3921.  
  3922. procedure HookHintHooks;
  3923. var
  3924.   ThreadID: Integer;
  3925. begin
  3926.   if not Application.FRunning then
  3927.   begin
  3928.     if HintHook = 0 then
  3929.       HintHook := SetWindowsHookEx(WH_GETMESSAGE, @HintGetMsgHook, 0, GetCurrentThreadID);
  3930.     if HintThread = 0 then
  3931.       HintThread := CreateThread(nil, 1000, @HintMouseThread, nil, 0, ThreadID);
  3932.   end;
  3933. end;
  3934.  
  3935. procedure UnhookHintHooks;
  3936. begin
  3937.   if HintHook <> 0 then UnhookWindowsHookEx(HintHook);
  3938.   HintHook := 0;
  3939.   if HintThread <> 0 then TerminateThread(HintThread, 0);
  3940.   HintThread := 0;
  3941. end;
  3942.  
  3943. function GetAnimation: Boolean;
  3944. var
  3945.   Info: TAnimationInfo;
  3946. begin
  3947.   Info.cbSize := SizeOf(TAnimationInfo);
  3948.   if SystemParametersInfo(SPI_GETANIMATION, 0, @Info, 0) then
  3949.     Result := Info.iMinAnimate else
  3950.     Result := False;
  3951. end;
  3952.  
  3953. procedure SetAnimation(Value: Boolean);
  3954. var
  3955.   Info: TAnimationInfo;
  3956. begin
  3957.   Info.cbSize := SizeOf(TAnimationInfo);
  3958.   Info.iMinAnimate := Value;
  3959.   SystemParametersInfo(SPI_SETANIMATION, 0, @Info, 0);
  3960. end;
  3961.  
  3962. procedure ShowWinNoAnimate(Handle: HWnd; CmdShow: Integer);
  3963. var
  3964.   Animation: Boolean;
  3965. begin
  3966.   Animation := GetAnimation;
  3967.   if Animation then SetAnimation(False);
  3968.   ShowWindow(Handle, CmdShow);
  3969.   if Animation then SetAnimation(True);
  3970. end;
  3971.  
  3972. { TApplication }
  3973.  
  3974. var
  3975.   WindowClass: TWndClass = (
  3976.     style: 0;
  3977.     lpfnWndProc: @DefWindowProc;
  3978.     cbClsExtra: 0;
  3979.     cbWndExtra: 0;
  3980.     hInstance: 0;
  3981.     hIcon: 0;
  3982.     hCursor: 0;
  3983.     hbrBackground: 0;
  3984.     lpszMenuName: nil;
  3985.     lpszClassName: 'TApplication');
  3986.  
  3987. constructor TApplication.Create(AOwner: TComponent);
  3988. var
  3989.   P: PChar;
  3990.   ModuleName: array[0..255] of Char;
  3991. begin
  3992.   inherited Create(AOwner);
  3993.   FTopMostList := TList.Create;
  3994.   FWindowHooks := TList.Create;
  3995.   FHintControl := nil;
  3996.   FHintWindow := nil;
  3997.   FHintColor := DefHintColor;
  3998.   FHintPause := DefHintPause;
  3999.   FHintShortPause := DefHintShortPause;
  4000.   FHintHidePause := DefHintHidePause;
  4001.   FShowHint := False;
  4002.   FActive := True;
  4003.   FIgnoreFontProperty := False;
  4004.   FIcon := TIcon.Create;
  4005.   FIcon.Handle := LoadIcon(hInstance, 'MAINICON');
  4006.   FIcon.OnChange := IconChanged;
  4007.   GetModuleFileName(HInstance, ModuleName, SizeOf(ModuleName));
  4008.   OemToAnsi(ModuleName, ModuleName);
  4009.   P := AnsiStrRScan(ModuleName, '\');
  4010.   if P <> nil then StrCopy(ModuleName, P + 1);
  4011.   P := AnsiStrScan(ModuleName, '.');
  4012.   if P <> nil then P^ := #0;
  4013.   AnsiLower(ModuleName + 1);
  4014.   FTitle := ModuleName;
  4015.   if not IsLibrary then CreateHandle;
  4016.   UpdateFormatSettings := True;
  4017.   FShowMainForm := True;
  4018. end;
  4019.  
  4020. destructor TApplication.Destroy;
  4021. begin
  4022.   FActive := False;
  4023.   FIgnoreFontProperty := False;
  4024.   CancelHint;
  4025.   inherited Destroy;
  4026.   UnhookMainWindow(CheckIniChange);
  4027.   if (FHandle <> 0) and FHandleCreated then
  4028.   begin
  4029.     if NewStyleControls then SendMessage(FHandle, WM_SETICON, 1, 0);
  4030.     DestroyWindow(FHandle);
  4031.   end;
  4032.   if FObjectInstance <> nil then FreeObjectInstance(FObjectInstance);
  4033.   DoneCtl3D;
  4034.   FWindowHooks.Free;
  4035. end;
  4036.  
  4037. procedure TApplication.CreateHandle;
  4038. var
  4039.   TempClass: TWndClass;
  4040.   SysMenu: HMenu;
  4041. begin
  4042.   if not FHandleCreated then
  4043.   begin
  4044.     FObjectInstance := MakeObjectInstance(WndProc);
  4045.     if not GetClassInfo(HInstance, WindowClass.lpszClassName, TempClass) then
  4046.     begin
  4047.       WindowClass.hInstance := HInstance;
  4048.       if Windows.RegisterClass(WindowClass) = 0 then
  4049.         raise EOutOfResources.CreateRes(SWindowClass);
  4050.     end;
  4051.     FHandle := CreateWindow(WindowClass.lpszClassName, PChar(FTitle),
  4052.       WS_POPUP or WS_CAPTION or WS_VISIBLE or WS_CLIPSIBLINGS or
  4053.       WS_SYSMENU or WS_MINIMIZEBOX,
  4054.       GetSystemMetrics(SM_CXSCREEN) div 2,
  4055.       GetSystemMetrics(SM_CYSCREEN) div 2,
  4056.       0, 0, 0, 0, HInstance, nil);
  4057.     FTitle := '';
  4058.     FHandleCreated := True;
  4059.     ShowWinNoAnimate(FHandle, SW_RESTORE);
  4060.     SetWindowLong(FHandle, GWL_WNDPROC, Longint(FObjectInstance));
  4061.     if NewStyleControls then
  4062.       SendMessage(FHandle, WM_SETICON, 1, GetIconHandle);
  4063.     SysMenu := GetSystemMenu(FHandle, False);
  4064.     DeleteMenu(SysMenu, SC_MAXIMIZE, MF_BYCOMMAND);
  4065.     DeleteMenu(SysMenu, SC_SIZE, MF_BYCOMMAND);
  4066.     if NewStyleControls then DeleteMenu(SysMenu, SC_MOVE, MF_BYCOMMAND);
  4067.   end;
  4068. end;
  4069.  
  4070. procedure TApplication.ControlDestroyed(Control: TControl);
  4071. begin
  4072.   if FMainForm = Control then FMainForm := nil;
  4073.   if FMouseControl = Control then FMouseControl := nil;
  4074.   if Screen.FActiveControl = Control then Screen.FActiveControl := nil;
  4075.   if Screen.FActiveForm = Control then Screen.FActiveForm := nil;
  4076.   if Screen.FFocusedForm = Control then Screen.FFocusedForm := nil;
  4077.   Screen.RestoreFocusForms.Remove(Control);
  4078.   if FHintControl = Control then FHintControl := nil;
  4079.   Screen.UpdateLastActive;
  4080. end;
  4081.  
  4082. function GetTopMostWindows(Handle: HWND; Info: Pointer): BOOL; stdcall;
  4083. begin
  4084.   Result := True;
  4085.   if GetWindow(Handle, GW_OWNER) = Application.Handle then
  4086.     if (GetWindowLong(Handle, GWL_EXSTYLE) and WS_EX_TOPMOST <> 0) and
  4087.       ((Application.MainForm = nil) or
  4088.       (Handle <> Application.MainForm.Handle)) then
  4089.       Application.FTopMostList.Add(Pointer(Handle))
  4090.     else
  4091.     begin
  4092.       HWND(Info^) := Handle;
  4093.       Result := False;
  4094.     end;
  4095. end;
  4096.  
  4097. procedure TApplication.NormalizeTopMosts;
  4098. var
  4099.   I: Integer;
  4100.   TopWindow: HWND;
  4101. begin
  4102.   if Application.Handle <> 0 then
  4103.   begin
  4104.     if FTopMostLevel = 0 then
  4105.     begin
  4106.       TopWindow := Handle;
  4107.       EnumWindows(@GetTopMostWindows, Longint(@TopWindow));
  4108.       if FTopMostList.Count <> 0 then
  4109.       begin
  4110.         TopWindow := GetWindow(TopWindow, GW_HWNDPREV);
  4111.         if GetWindowLong(TopWindow, GWL_EXSTYLE) and WS_EX_TOPMOST <> 0 then
  4112.           TopWindow := HWND_NOTOPMOST;
  4113.         for I := FTopMostList.Count - 1 downto 0 do
  4114.           SetWindowPos(HWND(FTopMostList[I]), TopWindow, 0, 0, 0, 0,
  4115.             SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
  4116.       end;
  4117.     end;
  4118.     Inc(FTopMostLevel);
  4119.   end;
  4120. end;
  4121.  
  4122. procedure TApplication.RestoreTopMosts;
  4123. var
  4124.   I: Integer;
  4125. begin
  4126.   if Application.Handle <> 0 then
  4127.   begin
  4128.     Dec(FTopMostLevel);
  4129.     if FTopMostLevel = 0 then
  4130.     begin
  4131.       for I := FTopMostList.Count - 1 downto 0 do
  4132.         SetWindowPos(HWND(FTopMostList[I]), HWND_TOPMOST, 0, 0, 0, 0,
  4133.           SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
  4134.       FTopMostList.Clear;
  4135.     end;
  4136.   end;
  4137. end;
  4138.  
  4139. function TApplication.CheckIniChange(var Message: TMessage): Boolean;
  4140. begin
  4141.   Result := False;
  4142.   case Message.Msg of
  4143.     WM_WININICHANGE: if UpdateFormatSettings then GetFormatSettings;
  4144.   end;
  4145. end;
  4146.  
  4147. procedure TApplication.WndProc(var Message: TMessage);
  4148. var
  4149.   I: Integer;
  4150.   SaveFocus, TopWindow: HWnd;
  4151.  
  4152.   procedure Default;
  4153.   begin
  4154.     with Message do
  4155.       Result := DefWindowProc(FHandle, Msg, WParam, LParam);
  4156.   end;
  4157.  
  4158.   procedure DrawAppIcon;
  4159.   var
  4160.     DC: HDC;
  4161.     PS: TPaintStruct;
  4162.   begin
  4163.     with Message do
  4164.     begin
  4165.       DC := BeginPaint(FHandle, PS);
  4166.       DrawIcon(DC, 0, 0, GetIconHandle);
  4167.       EndPaint(FHandle, PS);
  4168.     end;
  4169.   end;
  4170.  
  4171. begin
  4172.   try
  4173.     Message.Result := 0;
  4174.     for I := 0 to FWindowHooks.Count - 1 do
  4175.       if TWindowHook(FWindowHooks[I]^)(Message) then Exit;
  4176.     CheckIniChange(Message);
  4177.     with Message do
  4178.       case Msg of
  4179.         WM_SYSCOMMAND:
  4180.           case WParam and $FFF0 of
  4181.             SC_MINIMIZE: Minimize;
  4182.             SC_RESTORE: Restore;
  4183.           else
  4184.             Default;
  4185.           end;
  4186.         WM_CLOSE:
  4187.           if MainForm <> nil then MainForm.Close;
  4188.         WM_SYSCOLORCHANGE:
  4189.           if (Ctl3DHandle >= 32) and (@Ctl3DColorChange <> nil) then
  4190.             Ctl3DColorChange;
  4191.         WM_PAINT:
  4192.           if IsIconic(FHandle) then DrawAppIcon else Default;
  4193.         WM_ERASEBKGND:
  4194.           begin
  4195.             Message.Msg := WM_ICONERASEBKGND;
  4196.             Default;
  4197.           end;
  4198.         WM_QUERYDRAGICON:
  4199.           Result := GetIconHandle;
  4200.         WM_SETFOCUS:
  4201.           begin
  4202.             PostMessage(FHandle, CM_ENTER, 0, 0);
  4203.             Default;
  4204.           end;
  4205.         WM_ACTIVATEAPP:
  4206.           begin
  4207.             Default;
  4208.             FActive := TWMActivateApp(Message).Active;
  4209.             if TWMActivateApp(Message).Active then
  4210.             begin
  4211.               RestoreTopMosts;
  4212.               PostMessage(FHandle, CM_ACTIVATE, 0, 0)
  4213.             end
  4214.             else
  4215.             begin
  4216.               NormalizeTopMosts;
  4217.               PostMessage(FHandle, CM_DEACTIVATE, 0, 0);
  4218.             end;
  4219.           end;
  4220.         WM_ENABLE:
  4221.           if TWMEnable(Message).Enabled then
  4222.           begin
  4223.             RestoreTopMosts;
  4224.             if FWindowList <> nil then
  4225.             begin
  4226.               EnableTaskWindows(FWindowList);
  4227.               FWindowList := nil;
  4228.             end;
  4229.             Default;
  4230.           end else
  4231.           begin
  4232.             Default;
  4233.             if FWindowList = nil then
  4234.               FWindowList := DisableTaskWindows(Handle);
  4235.             NormalizeTopMosts;
  4236.           end;
  4237.         WM_CTLCOLORMSGBOX..WM_CTLCOLORSTATIC:
  4238.           Result := SendMessage(LParam, CN_BASE + Msg, WParam, LParam);
  4239.         WM_ENDSESSION: if TWMEndSession(Message).EndSession then Halt;
  4240.         CM_APPKEYDOWN:
  4241.           if (MainForm <> nil) and (MainForm.Menu <> nil) and
  4242.             IsWindowEnabled(MainForm.Handle) and
  4243.             MainForm.Menu.IsShortCut(TWMKey(Message)) then Result := 1;
  4244.         CM_APPSYSCOMMAND:
  4245.           if MainForm <> nil then
  4246.             with MainForm do
  4247.               if (Handle <> 0) and IsWindowEnabled(Handle) and
  4248.                 IsWindowVisible(Handle) then
  4249.               begin
  4250.                 FocusMessages := False;
  4251.                 SaveFocus := GetFocus;
  4252.                 Windows.SetFocus(Handle);
  4253.                 Perform(WM_SYSCOMMAND, WParam, LParam);
  4254.                 Windows.SetFocus(SaveFocus);
  4255.                 FocusMessages := True;
  4256.                 Result := 1;
  4257.               end;
  4258.         CM_ACTIVATE:
  4259.           if Assigned(FOnActivate) then FOnActivate(Self);
  4260.         CM_DEACTIVATE:
  4261.           if Assigned(FOnDeactivate) then FOnDeactivate(Self);
  4262.         CM_ENTER:
  4263.           if not IsIconic(FHandle) and (GetFocus = FHandle) then
  4264.           begin
  4265.             TopWindow := FindTopMostWindow(0);
  4266.             if TopWindow <> 0 then Windows.SetFocus(TopWindow);
  4267.           end;
  4268.         CM_INVOKEHELP: InvokeHelp(WParam, LParam);
  4269.         CM_WINDOWHOOK:
  4270.           if wParam = 0 then
  4271.             HookMainWindow(TWindowHook(Pointer(LParam)^)) else
  4272.             UnhookMainWindow(TWindowHook(Pointer(LParam)^));
  4273.         CM_DIALOGHANDLE:
  4274.           if wParam = 1 then
  4275.             Result := FDialogHandle
  4276.           else
  4277.             FDialogHandle := lParam;
  4278.       else
  4279.         Default;
  4280.       end;
  4281.   except
  4282.     HandleException(Self);
  4283.   end;
  4284. end;
  4285.  
  4286. function TApplication.GetIconHandle: HICON;
  4287. begin
  4288.   Result := FIcon.Handle;
  4289.   if Result = 0 then Result := LoadIcon(0, IDI_APPLICATION);
  4290. end;
  4291.  
  4292. procedure TApplication.Minimize;
  4293. begin
  4294.   if not IsIconic(FHandle) then
  4295.   begin
  4296.     NormalizeTopMosts;
  4297.     SetActiveWindow(FHandle);
  4298.     ShowWinNoAnimate(FHandle, SW_MINIMIZE);
  4299.     if Assigned(FOnMinimize) then FOnMinimize(Self);
  4300.   end;
  4301. end;
  4302.  
  4303. procedure TApplication.Restore;
  4304. begin
  4305.   if IsIconic(FHandle) then
  4306.   begin
  4307.     SetActiveWindow(FHandle);
  4308.     ShowWinNoAnimate(FHandle, SW_RESTORE);
  4309.     RestoreTopMosts;
  4310.     if Screen.ActiveControl <> nil then
  4311.       Windows.SetFocus(Screen.ActiveControl.Handle);
  4312.     if Assigned(FOnRestore) then FOnRestore(Self);
  4313.   end;
  4314. end;
  4315.  
  4316. procedure TApplication.BringToFront;
  4317. var
  4318.   TopWindow: HWnd;
  4319. begin
  4320.   if Handle <> 0 then
  4321.   begin
  4322.     TopWindow := GetLastActivePopup(Handle);
  4323.     if (TopWindow <> 0) and (TopWindow <> Handle) and
  4324.       IsWindowVisible(TopWindow) and IsWindowEnabled(TopWindow) then
  4325.       SetForegroundWindow(TopWindow);
  4326.   end;
  4327. end;
  4328.  
  4329. function TApplication.GetTitle: string;
  4330. var
  4331.   Buffer: array[0..255] of Char;
  4332. begin
  4333.   if FHandleCreated then
  4334.     SetString(Result, Buffer, GetWindowText(FHandle, Buffer,
  4335.       SizeOf(Buffer))) else
  4336.     Result := FTitle;
  4337. end;
  4338.  
  4339. procedure TApplication.SetIcon(Value: TIcon);
  4340. begin
  4341.   FIcon.Assign(Value);
  4342. end;
  4343.  
  4344. procedure TApplication.SetTitle(const Value: string);
  4345. begin
  4346.   if FHandleCreated then
  4347.     SetWindowText(FHandle, PChar(Value)) else
  4348.     FTitle := Value;
  4349. end;
  4350.  
  4351. procedure TApplication.SetHandle(Value: HWnd);
  4352. begin
  4353.   if not FHandleCreated and (Value <> FHandle) then
  4354.   begin
  4355.     if FHandle <> 0 then UnhookMainWindow(CheckIniChange);
  4356.     FHandle := Value;
  4357.     if FHandle <> 0 then HookMainWindow(CheckIniChange);
  4358.   end;
  4359. end;
  4360.  
  4361. function TApplication.IsDlgMsg(var Msg: TMsg): Boolean;
  4362. begin
  4363.   Result := False;
  4364.   if FDialogHandle <> 0 then
  4365.     Result := IsDialogMessage(FDialogHandle, Msg);
  4366. end;
  4367.  
  4368. function TApplication.IsMDIMsg(var Msg: TMsg): Boolean;
  4369. begin
  4370.   Result := False;
  4371.   if (MainForm <> nil) and (MainForm.FormStyle = fsMDIForm) and
  4372.     (Screen.ActiveForm <> nil) and
  4373.     (Screen.ActiveForm.FormStyle = fsMDIChild) then
  4374.     Result := TranslateMDISysAccel(MainForm.ClientHandle, Msg);
  4375. end;
  4376.  
  4377. function TApplication.IsKeyMsg(var Msg: TMsg): Boolean;
  4378. var
  4379.   WND: HWND;
  4380. begin
  4381.   Result := False;
  4382.   with Msg do
  4383.     if (Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST) and
  4384.       (GetCapture = 0) then
  4385.     begin
  4386.       Wnd := HWnd;
  4387.       if (MainForm <> nil) and (Wnd = MainForm.ClientHandle) then
  4388.         Wnd := MainForm.Handle;
  4389.       if SendMessage(Wnd, CN_BASE + Message, WParam, LParam) <> 0 then
  4390.         Result := True;
  4391.     end;
  4392. end;
  4393.  
  4394. function TApplication.IsHintMsg(var Msg: TMsg): Boolean;
  4395. begin
  4396.   Result := False;
  4397.   if (FHintWindow <> nil) and FHintWindow.IsHintMsg(Msg) then
  4398.     CancelHint;
  4399. end;
  4400.  
  4401. function TApplication.ProcessMessage: Boolean;
  4402. var
  4403.   Handled: Boolean;
  4404.   Msg: TMsg;
  4405. begin
  4406.   Result := False;
  4407.   if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
  4408.   begin
  4409.     Result := True;
  4410.     if Msg.Message <> WM_QUIT then
  4411.     begin
  4412.       Handled := False;
  4413.       if Assigned(FOnMessage) then FOnMessage(Msg, Handled);
  4414.       if not IsHintMsg(Msg) and not Handled and not IsMDIMsg(Msg) and
  4415.         not IsKeyMsg(Msg) and not IsDlgMsg(Msg) then
  4416.       begin
  4417.         TranslateMessage(Msg);
  4418.         DispatchMessage(Msg);
  4419.       end;
  4420.     end
  4421.     else
  4422.       FTerminate := True;
  4423.   end;
  4424. end;
  4425.  
  4426. procedure TApplication.ProcessMessages;
  4427. begin
  4428.   while ProcessMessage do {loop};
  4429. end;
  4430.  
  4431. procedure TApplication.HandleMessage;
  4432. begin
  4433.   if not ProcessMessage then Idle;
  4434. end;
  4435.  
  4436. procedure TApplication.HookMainWindow(Hook: TWindowHook);
  4437. var
  4438.   WindowHook: ^TWindowHook;
  4439. begin
  4440.   if not FHandleCreated then
  4441.   begin
  4442.     if FHandle <> 0 then
  4443.       SendMessage(FHandle, CM_WINDOWHOOK, 0, Longint(@@Hook));
  4444.   end else
  4445.   begin
  4446.     FWindowHooks.Expand;
  4447.     New(WindowHook);
  4448.     WindowHook^ := Hook;
  4449.     FWindowHooks.Add(WindowHook);
  4450.   end;
  4451. end;
  4452.  
  4453. procedure TApplication.UnhookMainWindow(Hook: TWindowHook);
  4454. var
  4455.   I: Integer;
  4456.   WindowHook: ^TWindowHook;
  4457. begin
  4458.   if not FHandleCreated then
  4459.   begin
  4460.     if FHandle <> 0 then
  4461.       SendMessage(FHandle, CM_WINDOWHOOK, 1, Longint(@@Hook));
  4462.   end else
  4463.     for I := 0 to FWindowHooks.Count - 1 do
  4464.     begin
  4465.       WindowHook := FWindowHooks[I];
  4466.       if (TMethod(WindowHook^).Code = TMethod(Hook).Code) and
  4467.         (TMethod(WindowHook^).Data = TMethod(Hook).Data) then
  4468.       begin
  4469.         Dispose(WindowHook);
  4470.         FWindowHooks.Delete(I);
  4471.         Break;
  4472.       end;
  4473.     end;
  4474. end;
  4475.  
  4476. procedure TApplication.Initialize;
  4477. begin
  4478.   if InitProc <> nil then TProcedure(InitProc);
  4479. end;
  4480.  
  4481. procedure TApplication.CreateForm(InstanceClass: TComponentClass; var Reference);
  4482. var
  4483.   Instance: TComponent;
  4484. begin
  4485.   Instance := TComponent(InstanceClass.NewInstance);
  4486.   TComponent(Reference) := Instance;
  4487.   try
  4488.     Instance.Create(Self);
  4489.   except
  4490.     TComponent(Reference) := nil;
  4491.     raise;
  4492.   end;
  4493.   if (FMainForm = nil) and (Instance is TForm) then
  4494.   begin
  4495.     TForm(Instance).HandleNeeded;
  4496.     FMainForm := TForm(Instance);
  4497.   end;
  4498. end;
  4499.  
  4500. procedure TApplication.Run;
  4501. begin
  4502.   FRunning := True;
  4503.   try
  4504.     AddExitProc(DoneApplication);
  4505.     if FMainForm <> nil then
  4506.     begin
  4507.       if FShowMainForm then FMainForm.Visible := True;
  4508.       repeat
  4509.         HandleMessage
  4510.       until Terminated;
  4511.     end;
  4512.   finally
  4513.     FRunning := False;
  4514.   end;
  4515. end;
  4516.  
  4517. procedure TApplication.Terminate;
  4518. begin
  4519.   PostQuitMessage(0);
  4520. end;
  4521.  
  4522. function IsClass(O: TObject; const Name: ShortString): Boolean;
  4523. var
  4524.   C: TClass;
  4525. begin
  4526.   C := O.ClassType;
  4527.   while C <> nil do begin
  4528.     if C.ClassName = Name then begin
  4529.       Result := True;
  4530.       exit;
  4531.     end;
  4532.     C := C.ClassParent;
  4533.   end;
  4534.   Result := False;
  4535. end;
  4536.  
  4537. procedure TApplication.HandleException(Sender: TObject);
  4538. begin
  4539.   if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
  4540. //  if ExceptObject is Exception then
  4541.   if IsClass(ExceptObject, 'Exception') then
  4542.   begin
  4543.     if not (ExceptObject is EAbort) then
  4544.       if Assigned(FOnException) then
  4545.         FOnException(Sender, Exception(ExceptObject))
  4546.       else
  4547.         ShowException(Exception(ExceptObject));
  4548.   end else
  4549.     SysUtils.ShowException(ExceptObject, ExceptAddr);
  4550. end;
  4551.  
  4552. function TApplication.MessageBox(Text, Caption: PChar; Flags: Word): Integer;
  4553. var
  4554.   ActiveWindow: HWnd;
  4555.   WindowList: Pointer;
  4556. begin
  4557.   ActiveWindow := GetActiveWindow;
  4558.   WindowList := DisableTaskWindows(0);
  4559.   try
  4560.     Result := Windows.MessageBox(Handle, Text, Caption, Flags);
  4561.   finally
  4562.     EnableTaskWindows(WindowList);
  4563.     SetActiveWindow(ActiveWindow);
  4564.   end;
  4565. end;
  4566.  
  4567. procedure TApplication.ShowException(E: Exception);
  4568. begin
  4569.   MessageBox(PChar(E.Message + '.'), PChar(GetTitle), MB_OK + MB_ICONSTOP);
  4570. end;
  4571.  
  4572. function TApplication.InvokeHelp(Command: Word; Data: Longint): Boolean;
  4573. var
  4574.   CallHelp: Boolean;
  4575.   HelpHandle: HWND;
  4576. begin
  4577.   Result := False;
  4578.   CallHelp := True;
  4579.   if Assigned(FOnHelp) then
  4580.     Result := FOnHelp(Command, Data, CallHelp);
  4581.   if CallHelp then
  4582.     if FHelpFile <> '' then
  4583.     begin
  4584.       HelpHandle := 0;
  4585.       if FMainForm <> nil then HelpHandle := FMainForm.Handle;
  4586.       Result := WinHelp(HelpHandle, PChar(FHelpFile), Command, Data);
  4587.     end else
  4588.       if not FHandleCreated then
  4589.         PostMessage(FHandle, CM_INVOKEHELP, Command, Data);
  4590. end;
  4591.  
  4592. function TApplication.HelpContext(Context: THelpContext): Boolean;
  4593. begin
  4594.   Result := InvokeHelp(HELP_CONTEXT, Context);
  4595. end;
  4596.  
  4597. function TApplication.HelpCommand(Command: Integer; Data: Longint): Boolean;
  4598. begin
  4599.   Result := InvokeHelp(Command, Data);
  4600. end;
  4601.  
  4602. function TApplication.HelpJump(const JumpID: string): Boolean;
  4603. var
  4604.   Command: array[0..255] of Char;
  4605. begin
  4606.   Result := True;
  4607.   if InvokeHelp(HELP_CONTENTS, 0) then
  4608.   begin
  4609.     StrLFmt(Command, SizeOf(Command) - 1, 'JumpID("","%s")', [JumpID]);
  4610.     Result := InvokeHelp(HELP_COMMAND, Longint(@Command));
  4611.   end;
  4612. end;
  4613.  
  4614. function TApplication.GetExeName: string;
  4615. begin
  4616.   Result := ParamStr(0);
  4617. end;
  4618.  
  4619. procedure TApplication.SetShowHint(Value: Boolean);
  4620. begin
  4621.   if FShowHint <> Value then
  4622.   begin
  4623.     FShowHint := Value;
  4624.     if FShowHint then
  4625.     begin
  4626.       FHintWindow := HintWindowClass.Create(Self);
  4627.       FHintWindow.Color := FHintColor;
  4628.     end
  4629.     else
  4630.     begin
  4631.       FHintWindow.Free;
  4632.       FHintWindow := nil;
  4633.     end;
  4634.   end;
  4635. end;
  4636.  
  4637. procedure TApplication.SetHintColor(Value: TColor);
  4638. begin
  4639.   if FHintColor <> Value then
  4640.   begin
  4641.     FHintColor := Value;
  4642.     if FHintWindow <> nil then
  4643.       FHintWindow.Color := FHintColor;
  4644.   end;
  4645. end;
  4646.  
  4647. procedure TApplication.Idle;
  4648. var
  4649.   P: TPoint;
  4650.   Control, CaptureControl: TControl;
  4651.   Done: Boolean;
  4652. begin
  4653.   GetCursorPos(P);
  4654.   Control := FindDragTarget(P, True);
  4655.   if (Control <> nil) and (csDesigning in Control.ComponentState) then
  4656.     Control := nil;
  4657.   CaptureControl := GetCaptureControl;
  4658.   if FMouseControl <> Control then
  4659.   begin
  4660.     if ((FMouseControl <> nil) and (CaptureControl = nil)) or
  4661.       ((CaptureControl <> nil) and (FMouseControl = CaptureControl)) then
  4662.       FMouseControl.Perform(CM_MOUSELEAVE, 0, 0);
  4663.     FMouseControl := Control;
  4664.     if ((FMouseControl <> nil) and (CaptureControl = nil)) or
  4665.       ((CaptureControl <> nil) and (FMouseControl = CaptureControl)) then
  4666.       FMouseControl.Perform(CM_MOUSEENTER, 0, 0);
  4667.   end;
  4668.   if FShowHint and ((FMouseControl = nil) or (FMouseControl = FHintWindow)) then
  4669.     CancelHint;
  4670.   Application.Hint := GetLongHint(GetHint(Control));
  4671.   Done := True;
  4672.   if Assigned(FOnIdle) then FOnIdle(Self, Done);
  4673.   if Done then WaitMessage;
  4674. end;
  4675.  
  4676. procedure TApplication.NotifyForms(Msg: Word);
  4677. var
  4678.   I: Integer;
  4679. begin
  4680.   for I := 0 to Screen.FormCount - 1 do Screen.Forms[I].Perform(Msg, 0, 0);
  4681. end;
  4682.  
  4683. procedure TApplication.IconChanged(Sender: TObject);
  4684. begin
  4685.   if NewStyleControls then
  4686.     SendMessage(FHandle, WM_SETICON, 1, GetIconHandle)
  4687.   else
  4688.     if IsIconic(FHandle) then InvalidateRect(FHandle, nil, True);
  4689.   NotifyForms(CM_ICONCHANGED);
  4690. end;
  4691.  
  4692. procedure TApplication.SetHint(const Value: string);
  4693. begin
  4694.   if FHint <> Value then
  4695.   begin
  4696.     FHint := Value;
  4697.     if Assigned(FOnHint) then FOnHint(Self);
  4698.   end;
  4699. end;
  4700.  
  4701. { Hint window processing }
  4702.  
  4703. procedure TApplication.StartHintTimer(Value: Integer; TimerMode: TTimerMode);
  4704. begin
  4705.   StopHintTimer;
  4706.   FTimerHandle := SetTimer(0, 1, Value, @HintTimerProc);
  4707.   FTimerActive := FTimerHandle > 0;
  4708.   FTimerMode := TimerMode;
  4709.   if not FTimerActive then CancelHint;
  4710. end;
  4711.  
  4712. procedure TApplication.StopHintTimer;
  4713. begin
  4714.   if FTimerActive then
  4715.   begin
  4716.     KillTimer(0, FTimerHandle);
  4717.     FTimerActive := False;
  4718.   end;
  4719. end;
  4720.  
  4721. procedure TApplication.HintMouseMessage(Control: TControl; var Message: TMessage);
  4722. var
  4723.   NewHintControl: TControl;
  4724.   Pause: Integer;
  4725.   WasHintActive: Boolean;
  4726. begin
  4727.   NewHintControl := GetHintControl(FindDragTarget(Control.ClientToScreen(SmallPointToPoint(TWMMouse(Message).Pos)), True));
  4728.   if (NewHintControl = nil) or not NewHintControl.ShowHint then
  4729.     CancelHint
  4730.   else
  4731.   begin
  4732.     if (NewHintControl <> FHintControl) or
  4733.       (not PtInRect(FHintCursorRect, Control.ClientToScreen(SmallPointToPoint(TWMMouse(Message).Pos)))) then
  4734.     begin
  4735.       WasHintActive := FHintActive;
  4736.       if WasHintActive then
  4737.         Pause := FHintShortPause else
  4738.         Pause := FHintPause;
  4739.       CancelHint;
  4740.       FHintActive := WasHintActive;
  4741.       FHintControl := NewHintControl;
  4742.       StartHintTimer(Pause, tmShow);
  4743.     end;
  4744.   end;
  4745. end;
  4746.  
  4747. procedure TApplication.HintTimerExpired;
  4748. var
  4749.   P: TPoint;
  4750. begin
  4751.   StopHintTimer;
  4752.   case FTimerMode of
  4753.     tmHide:
  4754.       HideHint;
  4755.     tmShow:
  4756.       begin
  4757.         GetCursorPos(P);
  4758.         ActivateHint(P);
  4759.       end;
  4760.   end;
  4761. end;
  4762.  
  4763. procedure TApplication.HideHint;
  4764. begin
  4765.   if (FHintWindow <> nil) and FHintWindow.HandleAllocated and
  4766.     IsWindowVisible(FHintWindow.Handle) then
  4767.     ShowWindow(FHintWindow.Handle, SW_HIDE);
  4768. end;
  4769.  
  4770. procedure TApplication.CancelHint;
  4771. begin
  4772.   if FHintControl <> nil then
  4773.   begin
  4774.     HideHint;
  4775.     FHintControl := nil;
  4776.     FHintActive := False;
  4777.     UnhookHintHooks;
  4778.     StopHintTimer;
  4779.   end;
  4780. end;
  4781.  
  4782. procedure TApplication.ActivateHint(CursorPos: TPoint);
  4783. var
  4784.   ClientOrigin, ParentOrigin: TPoint;
  4785.   HintInfo: THintInfo;
  4786.   HintStr: string;
  4787.   CanShow: Boolean;
  4788.   HintWinRect: TRect;
  4789. begin
  4790.   FHintActive := False;
  4791.   if FShowHint and (FHintControl <> nil) and (FHintWindow <> nil) and
  4792.      ForegroundTask then
  4793.   begin
  4794.     HintInfo.HintControl := FHintControl;
  4795.     HintInfo.HintPos := FHintControl.ClientOrigin;
  4796.     Inc(HintInfo.HintPos.Y, FHintControl.Height + 6);
  4797.     HintInfo.HintMaxWidth := Screen.Width;
  4798.     HintInfo.HintColor := FHintColor;
  4799.     HintInfo.CursorRect := FHintControl.BoundsRect;
  4800.     ClientOrigin := FHintControl.ClientOrigin;
  4801.     if FHintControl.Parent <> nil then
  4802.       ParentOrigin := FHintControl.Parent.ClientOrigin else
  4803.       ParentOrigin := Point(0, 0);
  4804.     OffsetRect(HintInfo.CursorRect, ParentOrigin.X - ClientOrigin.X,
  4805.       ParentOrigin.Y - ClientOrigin.Y);
  4806.     HintInfo.CursorPos := FHintControl.ScreenToClient(CursorPos);
  4807.  
  4808.     HintStr := GetShortHint(GetHint(FHintControl));
  4809.     CanShow := FHintControl.Perform(CM_HINTSHOW, 0, Longint(@HintInfo)) = 0;
  4810.     if CanShow and Assigned(FOnShowHint) then
  4811.       FOnShowHint(HintStr, CanShow, HintInfo);
  4812.     FHintActive := CanShow;
  4813.     if CanShow and (HintStr <> '') then
  4814.     begin
  4815.       { calculate the width of the hint based on HintStr and MaxWidth }
  4816.       HintWinRect := Bounds(0, 0, HintInfo.HintMaxWidth, 0);
  4817.       DrawText(FHintWindow.Canvas.Handle, PChar(HintStr), -1,
  4818.         HintWinRect, DT_CALCRECT or DT_LEFT or DT_WORDBREAK or DT_NOPREFIX);
  4819.       OffsetRect(HintWinRect, HintInfo.HintPos.X, HintInfo.HintPos.Y);
  4820.       Inc(HintWinRect.Right, 6);
  4821.       Inc(HintWinRect.Bottom, 2);
  4822.  
  4823.       { Convert the client's rect to screen coordinates }
  4824.       with HintInfo do
  4825.       begin
  4826.         FHintCursorRect.TopLeft := FHintControl.ClientToScreen(CursorRect.TopLeft);
  4827.         FHintCursorRect.BottomRight := FHintControl.ClientToScreen(CursorRect.BottomRight);
  4828.       end;
  4829.  
  4830.       FHintWindow.Color := HintInfo.HintColor;
  4831.       FHintWindow.ActivateHint(HintWinRect, HintStr);
  4832.       HookHintHooks;
  4833.       StartHintTimer(FHintHidePause, tmHide);
  4834.       Exit;
  4835.     end;
  4836.   end;
  4837.  CancelHint;
  4838. end;
  4839.  
  4840. function TApplication.GetDialogHandle: HWND;
  4841. begin
  4842.   if not FHandleCreated then
  4843.     Result := SendMessage(Handle, CM_DIALOGHANDLE, 1, 0)
  4844.   else
  4845.     Result := FDialogHandle;
  4846. end;
  4847.  
  4848. procedure TApplication.SetDialogHandle(Value: HWND);
  4849. begin
  4850.   if not FHandleCreated then
  4851.     SendMessage(Handle, CM_DIALOGHANDLE, 0, Value);
  4852.   FDialogHandle := Value;
  4853. end;
  4854.  
  4855. initialization
  4856.   Classes.FindGlobalComponent := FindGlobalComponent;
  4857. end.
  4858.